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 2 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