my-emacs-d/elpa/muse-3.20/httpd.el

289 lines
9.6 KiB
EmacsLisp
Raw Normal View History

2015-01-28 21:51:52 +00:00
;;; 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