Fix build failure for muse-ikiwiki.
[muse-el.git] / contrib / httpd.el
blob083dcb6575fdddfccc4fb4cb7ea4db6476f4b174
1 ;;; httpd.el -- a web server in Emacs Lisp
2 ;;;
3 ;;; Author: Eric Marsden <emarsden@laas.fr>
4 ;;; John Wiegley <johnw@gnu.org>
5 ;;; Michael Olson <mwolson@gnu.org> (slight modifications)
6 ;;; Version: 1.1
7 ;;; Keywords: games
8 ;;; Copyright (C) 2001, 2003 Eric Marsden
9 ;;; Parts copyright (C) 2006 Free Software Foundation, Inc.
10 ;;
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 3 of
14 ;; the License, or (at your option) any later version.
15 ;;
16 ;; This program is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20 ;;
21 ;; You should have received a copy of the GNU General Public
22 ;; License along with this program; if not, write to the Free
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
24 ;; MA 02111-1307, USA.
25 ;;
26 ;; The latest version of this package should be available from
27 ;;
28 ;; <URL:http://purl.org/net/emarsden/home/downloads/>
30 ;;; Commentary:
31 ;;
32 ;; httpd.el is an HTTP server embedded in the Emacs. It can handle GET
33 ;; and HEAD requests; adding support for POST should not be too
34 ;; difficult. By default, httpd.el will listen on server side Emacs
35 ;; sockets for HTTP requests.
36 ;;
37 ;; I have only tested this code with Emacs; it may need modifications
38 ;; to work with XEmacs.
39 ;;
40 ;; This version has been modified to work with GNU Emacs 21 and 22.
41 ;;
42 ;;; Acknowledgements:
43 ;;
44 ;; httpd.el was inspired by pshttpd, an HTTP server written in
45 ;; Postscript by Anders Karlsson <URL:http://www.pugo.org:8080/>.
46 ;;
47 ;; Thanks to John Wiegley and Cyprian Adam Laskowski.
49 ;;; Code
51 (defvar httpd-document-root "/var/www")
53 (defvar httpd-path-handlers '()
54 "Alist of (path-regexp . handler) forms.
55 If a GET request is made for an URL whose path component matches
56 a PATH-REGEXP, the corresponding handler is called to generate
57 content.")
59 (defvar httpd-mime-types-alist
60 '(("html" . "text/html; charset=iso-8859-1")
61 ("txt" . "text/plain; charset=iso-8859-1")
62 ("jpg" . "image/jpeg")
63 ("jpeg" . "image/jpeg")
64 ("gif" . "image/gif")
65 ("png" . "image/png")
66 ("tif" . "image/tiff")
67 ("tiff" . "image/tiff")
68 ("css" . "text/css")
69 ("gz" . "application/octet-stream")
70 ("ps" . "application/postscript")
71 ("pdf" . "application/pdf")
72 ("eps" . "application/postscript")
73 ("tar" . "application/x-tar")
74 ("rpm" . "application/x-rpm")
75 ("zip" . "application/zip")
76 ("mp3" . "audio/mpeg")
77 ("mp2" . "audio/mpeg")
78 ("mid" . "audio/midi")
79 ("midi" . "audio/midi")
80 ("wav" . "audio/x-wav")
81 ("au" . "audio/basic")
82 ("ram" . "audio/pn-realaudio")
83 ("ra" . "audio/x-realaudio")
84 ("mpg" . "video/mpeg")
85 ("mpeg" . "video/mpeg")
86 ("qt" . "video/quicktime")
87 ("mov" . "video/quicktime")
88 ("avi" . "video/x-msvideo")))
90 (defun httpd-mime-type (filename)
91 (or (cdr (assoc (file-name-extension filename) httpd-mime-types-alist))
92 "text/plain"))
94 (put 'httpd-exception 'error-conditions '(httpd-exception error))
96 (defun defhttpd-exception (name code msg)
97 (put name 'error-conditions (list name 'httpd-exception 'error))
98 (put name 'httpd-code code)
99 (put name 'httpd-msg msg))
101 (defhttpd-exception 'httpd-moved/perm 301 "Moved permanently")
102 (defhttpd-exception 'httpd-moved/temp 302 "Moved temporarily")
103 (defhttpd-exception 'httpd-bad-request 400 "Bad request")
104 (defhttpd-exception 'httpd-forbidden 403 "Forbidden")
105 (defhttpd-exception 'httpd-file-not-found 404 "Not found")
106 (defhttpd-exception 'httpd-method-forbidden 405 "Method not allowed")
107 (defhttpd-exception 'httpd-unimplemented 500 "Internal server error")
108 (defhttpd-exception 'httpd-unimplemented 501 "Not implemented")
109 (defhttpd-exception 'httpd-unimplemented 503 "Service unavailable")
111 (defvar httpd-endl "\r\n")
113 (defvar httpd-process nil)
114 (defvar httpd-bytes-sent nil) ; only used with `httpd-process'
115 (defvar httpd-log-accesses t)
117 (defun httpd-add-handler (path-regexp handler)
118 (push (cons path-regexp handler) httpd-path-handlers))
120 (defun httpd-try-internal-handler (path &optional cont)
121 (catch 'result
122 (dolist (elem httpd-path-handlers)
123 (let ((regexp (car elem))
124 (handler (cdr elem)))
125 (if (string-match regexp path)
126 (throw 'result (funcall handler path cont)))))))
128 (defun httpd-date-stamp ()
129 (format-time-string "[%d/%b/%Y %H:%M:%S %z]"))
131 (defun httpd-log (&rest strings)
132 (if httpd-log-accesses
133 (save-excursion
134 (goto-char (point-max))
135 (with-current-buffer (get-buffer-create "*httpd access_log*")
136 (mapc 'insert strings)))))
138 (defun httpd-send-data (&rest strings)
139 (dolist (s strings)
140 (send-string httpd-process s)
141 (if httpd-bytes-sent
142 (setq httpd-bytes-sent (+ httpd-bytes-sent (length s))))))
144 (defun httpd-send (code msg &rest strings)
145 (httpd-log (number-to-string code) " ")
146 (apply 'httpd-send-data
147 "HTTP/1.0 " (number-to-string code) " " msg httpd-endl
148 strings))
150 (defun httpd-send-eof ()
151 (httpd-log (number-to-string httpd-bytes-sent) "\n")
152 (process-send-eof httpd-process))
154 (defun httpd-send-file (filename)
155 (with-temp-buffer
156 (insert-file-contents filename)
157 (httpd-send-data (buffer-string))))
159 (defun httpd-lose (code msg)
160 (httpd-send code msg
161 "Content-Type: text/html" httpd-endl
162 "Connection: close" httpd-endl
163 httpd-endl
164 "<html><head><title>Error</title></head>" httpd-endl
165 "<body><h1>" msg "</h1>" httpd-endl
166 "<p>" msg httpd-endl
167 "</body></html>" httpd-endl)
168 (httpd-send-eof))
170 (defun httpd-handle-redirect (req where)
171 "Redirect the client to new location WHERE."
172 (httpd-send 301 "Moved permanently"
173 "Location: " where httpd-endl
174 "URI: " where httpd-endl
175 "Connection: close" httpd-endl
176 httpd-endl)
177 (httpd-send-eof))
179 (defun httpd-handle-GET+HEAD (path &optional want-data req)
180 (if (zerop (length path))
181 (setq path "index.html"))
183 ;; could use `expand-file-name' here instead of `concat', but we
184 ;; don't want tilde expansion, etc.
185 (let ((filename (concat httpd-document-root "/" path))
186 modified-since)
187 (cond ((httpd-try-internal-handler path) t)
188 ((file-directory-p filename)
189 (httpd-handle-redirect path (concat "http://" (system-name) "/"
190 path "/")))
191 ((file-readable-p filename)
192 (let ((attrs (file-attributes filename)))
193 (if (and (string-match "^If-Modified-Since:\\s-+\\(.+\\)" req)
194 (setq modified-since
195 (apply 'encode-time
196 (parse-time-string (match-string 1 req))))
197 (time-less-p (nth 5 attrs) modified-since))
198 (httpd-send 304 "Not modified"
199 "Server: Emacs/httpd.el" httpd-endl
200 "Connection: close" httpd-endl
201 httpd-endl)
202 (httpd-send 200 "OK"
203 "Server: Emacs/httpd.el" httpd-endl
204 "Connection: close" httpd-endl
205 "MIME-Version: 1.0" httpd-endl
206 "Content-Type: "
207 (httpd-mime-type filename) httpd-endl
208 "Content-Length: "
209 (number-to-string (nth 7 attrs)) httpd-endl
210 httpd-endl)
211 (if want-data
212 (httpd-send-file filename)))
213 (httpd-send-eof)))
215 (t (signal 'httpd-file-not-found path)))))
217 (defun httpd-handle-request (req &optional cont)
218 (httpd-log (car (process-contact httpd-process)) " - - "
219 (httpd-date-stamp) " \"")
220 (if (not (string-match ".+" req))
221 (progn
222 (httpd-log "\"")
223 (error "HTTP request was empty"))
224 (let ((request (match-string 0 req)))
225 (httpd-log request "\" ")
226 (cond
227 ((string-match "\\.\\." request)
228 ;; reject requests containing ".." in the path. Should really
229 ;; URI-decode first.
230 (signal 'httpd-forbidden request))
232 ((string-match "\\`\\(GET\\|HEAD\\|POST\\)\\s-/\\(\\S-*\\)" request)
233 (let ((kind (match-string 1 request))
234 (arg (match-string 2 request)))
235 (if (string= kind "POST")
236 (unless (httpd-try-internal-handler arg cont)
237 (signal 'httpd-unimplemented arg))
238 (httpd-handle-GET+HEAD arg (string= kind "GET") req))))
240 (t (signal 'httpd-bad-request request))))))
242 (defun httpd-serve (proc string)
243 (let ((httpd-process proc)
244 (httpd-bytes-sent 0))
245 (condition-case why
246 (httpd-handle-request string)
247 (httpd-exception
248 (httpd-lose (get (car why) 'httpd-code)
249 (get (car why) 'httpd-msg)))
250 ;; Comment out these two lines if you want to catch errors
251 ;; inside Emacs itself.
252 (error
253 (httpd-lose 500 (format "Emacs Lisp error: %s" why)))
254 )))
256 (defun httpd-start (&optional port)
257 (interactive (list (read-string "Serve Web requests on port: " "8080")))
258 (if (null port)
259 (setq port 8080)
260 (if (stringp port)
261 (setq port (string-to-number port))))
262 (if httpd-process
263 (delete-process httpd-process))
264 (setq httpd-process
265 (if (fboundp 'make-network-process)
266 (make-network-process :name "httpd"
267 :buffer (generate-new-buffer "httpd")
268 :host 'local :service port
269 :server t :noquery t
270 :filter 'httpd-serve)
271 (and (fboundp 'open-network-stream-server)
272 (open-network-stream-server "httpd"
273 (generate-new-buffer "httpd")
274 port nil 'httpd-serve))))
275 (if (and (processp httpd-process)
276 (eq (process-status httpd-process) 'listen))
277 (message "httpd.el is listening on port %d" port)))
279 (defun httpd-stop ()
280 (interactive)
281 (when httpd-process
282 (message "httpd.el server on port %d has stopped"
283 (cadr (process-contact httpd-process)))
284 (delete-process httpd-process)
285 (setq httpd-process nil)))
287 (provide 'httpd)
289 ;; httpd.el ends here