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