083dcb6575fdddfccc4fb4cb7ea4db6476f4b174
[muse-el.git] / contrib / httpd.el
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/>
29
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.
48
49 ;;; Code
50
51 (defvar httpd-document-root "/var/www")
52
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.")
58
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")))
89
90 (defun httpd-mime-type (filename)
91   (or (cdr (assoc (file-name-extension filename) httpd-mime-types-alist))
92       "text/plain"))
93
94 (put 'httpd-exception 'error-conditions '(httpd-exception error))
95
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))
100
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")
110
111 (defvar httpd-endl "\r\n")
112
113 (defvar httpd-process nil)
114 (defvar httpd-bytes-sent nil)           ; only used with `httpd-process'
115 (defvar httpd-log-accesses t)
116
117 (defun httpd-add-handler (path-regexp handler)
118   (push (cons path-regexp handler) httpd-path-handlers))
119
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)))))))
127
128 (defun httpd-date-stamp ()
129   (format-time-string "[%d/%b/%Y %H:%M:%S %z]"))
130
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)))))
137
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))))))
143
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))
149
150 (defun httpd-send-eof ()
151   (httpd-log (number-to-string httpd-bytes-sent) "\n")
152   (process-send-eof httpd-process))
153
154 (defun httpd-send-file (filename)
155   (with-temp-buffer
156     (insert-file-contents filename)
157     (httpd-send-data (buffer-string))))
158
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))
169
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))
178
179 (defun httpd-handle-GET+HEAD (path &optional want-data req)
180   (if (zerop (length path))
181       (setq path "index.html"))
182
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)))
214
215           (t (signal 'httpd-file-not-found path)))))
216
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))
231
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))))
239
240        (t (signal 'httpd-bad-request request))))))
241
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       )))
255
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)))
278
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)))
286
287 (provide 'httpd)
288
289 ;; httpd.el ends here