289 lines
9.6 KiB
EmacsLisp
289 lines
9.6 KiB
EmacsLisp
|
;;; httpd.el -- A web server in Emacs Lisp
|
||
|
|
|
||
|
|
;; Copyright (C) 2001, 2003, 2006, 2012 Free Software Foundation, Inc.
|
||
|
|
|
||
|
|
;; Author: Eric Marsden <emarsden@laas.fr>
|
||
|
|
;; John Wiegley <johnw@gnu.org>
|
||
|
|
;; Michael Olson <mwolson@gnu.org> (slight modifications)
|
||
|
|
;; Version: 1.1
|
||
|
|
;; Keywords: games
|
||
|
|
|
||
|
|
;; This program is free software; you can redistribute it and/or
|
||
|
|
;; modify it under the terms of the GNU General Public License as
|
||
|
|
;; published by the Free Software Foundation; either version 3 of
|
||
|
|
;; the License, or (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
;; GNU General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public
|
||
|
|
;; License along with this program; if not, write to the Free
|
||
|
|
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
|
||
|
|
;; MA 02111-1307, USA.
|
||
|
|
;;
|
||
|
|
;; The latest version of this package should be available from
|
||
|
|
;;
|
||
|
|
;; <URL:http://purl.org/net/emarsden/home/downloads/>
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;; httpd.el is an HTTP server embedded in the Emacs. It can handle GET
|
||
|
|
;; and HEAD requests; adding support for POST should not be too
|
||
|
|
;; difficult. By default, httpd.el will listen on server side Emacs
|
||
|
|
;; sockets for HTTP requests.
|
||
|
|
;;
|
||
|
|
;; I have only tested this code with Emacs; it may need modifications
|
||
|
|
;; to work with XEmacs.
|
||
|
|
;;
|
||
|
|
;; This version has been modified to work with GNU Emacs 21 and 22.
|
||
|
|
;;
|
||
|
|
;;; Acknowledgements:
|
||
|
|
;;
|
||
|
|
;; httpd.el was inspired by pshttpd, an HTTP server written in
|
||
|
|
;; Postscript by Anders Karlsson <URL:http://www.pugo.org:8080/>.
|
||
|
|
;;
|
||
|
|
;; Thanks to John Wiegley and Cyprian Adam Laskowski.
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(defvar httpd-document-root "/var/www")
|
||
|
|
|
||
|
|
(defvar httpd-path-handlers '()
|
||
|
|
"Alist of (path-regexp . handler) forms.
|
||
|
|
If a GET request is made for an URL whose path component matches
|
||
|
|
a PATH-REGEXP, the corresponding handler is called to generate
|
||
|
|
content.")
|
||
|
|
|
||
|
|
(defvar httpd-mime-types-alist
|
||
|
|
'(("html" . "text/html; charset=iso-8859-1")
|
||
|
|
("txt" . "text/plain; charset=iso-8859-1")
|
||
|
|
("jpg" . "image/jpeg")
|
||
|
|
("jpeg" . "image/jpeg")
|
||
|
|
("gif" . "image/gif")
|
||
|
|
("png" . "image/png")
|
||
|
|
("tif" . "image/tiff")
|
||
|
|
("tiff" . "image/tiff")
|
||
|
|
("css" . "text/css")
|
||
|
|
("gz" . "application/octet-stream")
|
||
|
|
("ps" . "application/postscript")
|
||
|
|
("pdf" . "application/pdf")
|
||
|
|
("eps" . "application/postscript")
|
||
|
|
("tar" . "application/x-tar")
|
||
|
|
("rpm" . "application/x-rpm")
|
||
|
|
("zip" . "application/zip")
|
||
|
|
("mp3" . "audio/mpeg")
|
||
|
|
("mp2" . "audio/mpeg")
|
||
|
|
("mid" . "audio/midi")
|
||
|
|
("midi" . "audio/midi")
|
||
|
|
("wav" . "audio/x-wav")
|
||
|
|
("au" . "audio/basic")
|
||
|
|
("ram" . "audio/pn-realaudio")
|
||
|
|
("ra" . "audio/x-realaudio")
|
||
|
|
("mpg" . "video/mpeg")
|
||
|
|
("mpeg" . "video/mpeg")
|
||
|
|
("qt" . "video/quicktime")
|
||
|
|
("mov" . "video/quicktime")
|
||
|
|
("avi" . "video/x-msvideo")))
|
||
|
|
|
||
|
|
(defun httpd-mime-type (filename)
|
||
|
|
(or (cdr (assoc (file-name-extension filename) httpd-mime-types-alist))
|
||
|
|
"text/plain"))
|
||
|
|
|
||
|
|
(put 'httpd-exception 'error-conditions '(httpd-exception error))
|
||
|
|
|
||
|
|
(defun defhttpd-exception (name code msg)
|
||
|
|
(put name 'error-conditions (list name 'httpd-exception 'error))
|
||
|
|
(put name 'httpd-code code)
|
||
|
|
(put name 'httpd-msg msg))
|
||
|
|
|
||
|
|
(defhttpd-exception 'httpd-moved/perm 301 "Moved permanently")
|
||
|
|
(defhttpd-exception 'httpd-moved/temp 302 "Moved temporarily")
|
||
|
|
(defhttpd-exception 'httpd-bad-request 400 "Bad request")
|
||
|
|
(defhttpd-exception 'httpd-forbidden 403 "Forbidden")
|
||
|
|
(defhttpd-exception 'httpd-file-not-found 404 "Not found")
|
||
|
|
(defhttpd-exception 'httpd-method-forbidden 405 "Method not allowed")
|
||
|
|
(defhttpd-exception 'httpd-unimplemented 500 "Internal server error")
|
||
|
|
(defhttpd-exception 'httpd-unimplemented 501 "Not implemented")
|
||
|
|
(defhttpd-exception 'httpd-unimplemented 503 "Service unavailable")
|
||
|
|
|
||
|
|
(defvar httpd-endl "\r\n")
|
||
|
|
|
||
|
|
(defvar httpd-process nil)
|
||
|
|
(defvar httpd-bytes-sent nil) ; only used with `httpd-process'
|
||
|
|
(defvar httpd-log-accesses t)
|
||
|
|
|
||
|
|
(defun httpd-add-handler (path-regexp handler)
|
||
|
|
(push (cons path-regexp handler) httpd-path-handlers))
|
||
|
|
|
||
|
|
(defun httpd-try-internal-handler (path &optional cont)
|
||
|
|
(catch 'result
|
||
|
|
(dolist (elem httpd-path-handlers)
|
||
|
|
(let ((regexp (car elem))
|
||
|
|
(handler (cdr elem)))
|
||
|
|
(if (string-match regexp path)
|
||
|
|
(throw 'result (funcall handler path cont)))))))
|
||
|
|
|
||
|
|
(defun httpd-date-stamp ()
|
||
|
|
(format-time-string "[%d/%b/%Y %H:%M:%S %z]"))
|
||
|
|
|
||
|
|
(defun httpd-log (&rest strings)
|
||
|
|
(if httpd-log-accesses
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-max))
|
||
|
|
(with-current-buffer (get-buffer-create "*httpd access_log*")
|
||
|
|
(mapc 'insert strings)))))
|
||
|
|
|
||
|
|
(defun httpd-send-data (&rest strings)
|
||
|
|
(dolist (s strings)
|
||
|
|
(send-string httpd-process s)
|
||
|
|
(if httpd-bytes-sent
|
||
|
|
(setq httpd-bytes-sent (+ httpd-bytes-sent (length s))))))
|
||
|
|
|
||
|
|
(defun httpd-send (code msg &rest strings)
|
||
|
|
(httpd-log (number-to-string code) " ")
|
||
|
|
(apply 'httpd-send-data
|
||
|
|
"HTTP/1.0 " (number-to-string code) " " msg httpd-endl
|
||
|
|
strings))
|
||
|
|
|
||
|
|
(defun httpd-send-eof ()
|
||
|
|
(httpd-log (number-to-string httpd-bytes-sent) "\n")
|
||
|
|
(process-send-eof httpd-process))
|
||
|
|
|
||
|
|
(defun httpd-send-file (filename)
|
||
|
|
(with-temp-buffer
|
||
|
|
(insert-file-contents filename)
|
||
|
|
(httpd-send-data (buffer-string))))
|
||
|
|
|
||
|
|
(defun httpd-lose (code msg)
|
||
|
|
(httpd-send code msg
|
||
|
|
"Content-Type: text/html" httpd-endl
|
||
|
|
"Connection: close" httpd-endl
|
||
|
|
httpd-endl
|
||
|
|
"<html><head><title>Error</title></head>" httpd-endl
|
||
|
|
"<body><h1>" msg "</h1>" httpd-endl
|
||
|
|
"<p>" msg httpd-endl
|
||
|
|
"</body></html>" httpd-endl)
|
||
|
|
(httpd-send-eof))
|
||
|
|
|
||
|
|
(defun httpd-handle-redirect (req where)
|
||
|
|
"Redirect the client to new location WHERE."
|
||
|
|
(httpd-send 301 "Moved permanently"
|
||
|
|
"Location: " where httpd-endl
|
||
|
|
"URI: " where httpd-endl
|
||
|
|
"Connection: close" httpd-endl
|
||
|
|
httpd-endl)
|
||
|
|
(httpd-send-eof))
|
||
|
|
|
||
|
|
(defun httpd-handle-GET+HEAD (path &optional want-data req)
|
||
|
|
(if (zerop (length path))
|
||
|
|
(setq path "index.html"))
|
||
|
|
|
||
|
|
;; could use `expand-file-name' here instead of `concat', but we
|
||
|
|
;; don't want tilde expansion, etc.
|
||
|
|
(let ((filename (concat httpd-document-root "/" path))
|
||
|
|
modified-since)
|
||
|
|
(cond ((httpd-try-internal-handler path) t)
|
||
|
|
((file-directory-p filename)
|
||
|
|
(httpd-handle-redirect path (concat "http://" (system-name) "/"
|
||
|
|
path "/")))
|
||
|
|
((file-readable-p filename)
|
||
|
|
(let ((attrs (file-attributes filename)))
|
||
|
|
(if (and (string-match "^If-Modified-Since:\\s-+\\(.+\\)" req)
|
||
|
|
(setq modified-since
|
||
|
|
(apply 'encode-time
|
||
|
|
(parse-time-string (match-string 1 req))))
|
||
|
|
(time-less-p (nth 5 attrs) modified-since))
|
||
|
|
(httpd-send 304 "Not modified"
|
||
|
|
"Server: Emacs/httpd.el" httpd-endl
|
||
|
|
"Connection: close" httpd-endl
|
||
|
|
httpd-endl)
|
||
|
|
(httpd-send 200 "OK"
|
||
|
|
"Server: Emacs/httpd.el" httpd-endl
|
||
|
|
"Connection: close" httpd-endl
|
||
|
|
"MIME-Version: 1.0" httpd-endl
|
||
|
|
"Content-Type: "
|
||
|
|
(httpd-mime-type filename) httpd-endl
|
||
|
|
"Content-Length: "
|
||
|
|
(number-to-string (nth 7 attrs)) httpd-endl
|
||
|
|
httpd-endl)
|
||
|
|
(if want-data
|
||
|
|
(httpd-send-file filename)))
|
||
|
|
(httpd-send-eof)))
|
||
|
|
|
||
|
|
(t (signal 'httpd-file-not-found path)))))
|
||
|
|
|
||
|
|
(defun httpd-handle-request (req &optional cont)
|
||
|
|
(httpd-log (car (process-contact httpd-process)) " - - "
|
||
|
|
(httpd-date-stamp) " \"")
|
||
|
|
(if (not (string-match ".+" req))
|
||
|
|
(progn
|
||
|
|
(httpd-log "\"")
|
||
|
|
(error "HTTP request was empty"))
|
||
|
|
(let ((request (match-string 0 req)))
|
||
|
|
(httpd-log request "\" ")
|
||
|
|
(cond
|
||
|
|
((string-match "\\.\\." request)
|
||
|
|
;; reject requests containing ".." in the path. Should really
|
||
|
|
;; URI-decode first.
|
||
|
|
(signal 'httpd-forbidden request))
|
||
|
|
|
||
|
|
((string-match "\\`\\(GET\\|HEAD\\|POST\\)\\s-/\\(\\S-*\\)" request)
|
||
|
|
(let ((kind (match-string 1 request))
|
||
|
|
(arg (match-string 2 request)))
|
||
|
|
(if (string= kind "POST")
|
||
|
|
(unless (httpd-try-internal-handler arg cont)
|
||
|
|
(signal 'httpd-unimplemented arg))
|
||
|
|
(httpd-handle-GET+HEAD arg (string= kind "GET") req))))
|
||
|
|
|
||
|
|
(t (signal 'httpd-bad-request request))))))
|
||
|
|
|
||
|
|
(defun httpd-serve (proc string)
|
||
|
|
(let ((httpd-process proc)
|
||
|
|
(httpd-bytes-sent 0))
|
||
|
|
(condition-case why
|
||
|
|
(httpd-handle-request string)
|
||
|
|
(httpd-exception
|
||
|
|
(httpd-lose (get (car why) 'httpd-code)
|
||
|
|
(get (car why) 'httpd-msg)))
|
||
|
|
;; Comment out these two lines if you want to catch errors
|
||
|
|
;; inside Emacs itself.
|
||
|
|
(error
|
||
|
|
(httpd-lose 500 (format "Emacs Lisp error: %s" why)))
|
||
|
|
)))
|
||
|
|
|
||
|
|
(defun httpd-start (&optional port)
|
||
|
|
(interactive (list (read-string "Serve Web requests on port: " "8080")))
|
||
|
|
(if (null port)
|
||
|
|
(setq port 8080)
|
||
|
|
(if (stringp port)
|
||
|
|
(setq port (string-to-number port))))
|
||
|
|
(if httpd-process
|
||
|
|
(delete-process httpd-process))
|
||
|
|
(setq httpd-process
|
||
|
|
(if (fboundp 'make-network-process)
|
||
|
|
(make-network-process :name "httpd"
|
||
|
|
:buffer (generate-new-buffer "httpd")
|
||
|
|
:host 'local :service port
|
||
|
|
:server t :noquery t
|
||
|
|
:filter 'httpd-serve)
|
||
|
|
(and (fboundp 'open-network-stream-server)
|
||
|
|
(open-network-stream-server "httpd"
|
||
|
|
(generate-new-buffer "httpd")
|
||
|
|
port nil 'httpd-serve))))
|
||
|
|
(if (and (processp httpd-process)
|
||
|
|
(eq (process-status httpd-process) 'listen))
|
||
|
|
(message "httpd.el is listening on port %d" port)))
|
||
|
|
|
||
|
|
(defun httpd-stop ()
|
||
|
|
(interactive)
|
||
|
|
(when httpd-process
|
||
|
|
(message "httpd.el server on port %d has stopped"
|
||
|
|
(cadr (process-contact httpd-process)))
|
||
|
|
(delete-process httpd-process)
|
||
|
|
(setq httpd-process nil)))
|
||
|
|
|
||
|
|
(provide 'httpd)
|
||
|
|
;;; httpd.el ends here
|