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