240 lines
9.0 KiB
EmacsLisp
240 lines
9.0 KiB
EmacsLisp
;;; muse-http.el --- publish HTML files over HTTP
|
|
|
|
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
|
;; Free Software Foundation, Inc.
|
|
|
|
;; This file is part of Emacs Muse. It is not part of GNU Emacs.
|
|
|
|
;; Emacs Muse 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, or (at your
|
|
;; option) any later version.
|
|
|
|
;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Contributors:
|
|
|
|
;;; Code:
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Publishing HTML over HTTP (using httpd.el)
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require 'muse-html)
|
|
(require 'muse-project)
|
|
(require 'httpd)
|
|
(require 'cgi)
|
|
|
|
(defgroup muse-http nil
|
|
"Options controlling the behavior of Emacs Muse over HTTP."
|
|
:group 'press)
|
|
|
|
(defcustom muse-http-maintainer (concat "webmaster@" (system-name))
|
|
"The maintainer address to use for the HTTP 'From' field."
|
|
:type 'string
|
|
:group 'muse-http)
|
|
|
|
(defcustom muse-http-publishing-style "html"
|
|
"The style to use when publishing projects over http."
|
|
:type 'string
|
|
:group 'muse-http)
|
|
|
|
(defcustom muse-http-max-cache-size 64
|
|
"The number of pages to cache when serving over HTTP.
|
|
This only applies if set while running the persisted invocation
|
|
server. See main documentation for the `muse-http'
|
|
customization group."
|
|
:type 'integer
|
|
:group 'muse-http)
|
|
|
|
(defvar muse-buffer-mtime nil)
|
|
(make-variable-buffer-local 'muse-buffer-mtime)
|
|
|
|
(defun muse-sort-buffers (l r)
|
|
(let ((l-mtime (with-current-buffer l muse-buffer-mtime))
|
|
(r-mtime (with-current-buffer r muse-buffer-mtime)))
|
|
(cond
|
|
((and (null l-mtime) (null r-mtime)) l)
|
|
((null l-mtime) r)
|
|
((null r-mtime) l)
|
|
(t (muse-time-less-p r-mtime l-mtime)))))
|
|
|
|
(defun muse-winnow-list (entries &optional predicate)
|
|
"Return only those ENTRIES for which PREDICATE returns non-nil."
|
|
(let ((flist (list t)))
|
|
(let ((entry entries))
|
|
(while entry
|
|
(if (funcall predicate (car entry))
|
|
(nconc flist (list (car entry))))
|
|
(setq entry (cdr entry))))
|
|
(cdr flist)))
|
|
|
|
(defun muse-http-prune-cache ()
|
|
"If the page cache has become too large, prune it."
|
|
(let* ((buflist
|
|
(sort (muse-winnow-list (buffer-list)
|
|
(function
|
|
(lambda (buf)
|
|
(with-current-buffer buf
|
|
muse-buffer-mtime))))
|
|
'muse-sort-buffers))
|
|
(len (length buflist)))
|
|
(while (> len muse-http-max-cache-size)
|
|
(kill-buffer (car buflist))
|
|
(setq len (1- len)))))
|
|
|
|
(defvar muse-http-serving-p nil)
|
|
|
|
(defun muse-http-send-buffer (&optional modified code msg)
|
|
"Markup and send the contents of the current buffer via HTTP."
|
|
(httpd-send (or code 200) (or msg "OK")
|
|
"Server: muse.el/" muse-version httpd-endl
|
|
"Connection: close" httpd-endl
|
|
"MIME-Version: 1.0" httpd-endl
|
|
"Date: " (format-time-string "%a, %e %b %Y %T %Z")
|
|
httpd-endl
|
|
"From: " muse-http-maintainer httpd-endl)
|
|
(when modified
|
|
(httpd-send-data "Last-Modified: "
|
|
(format-time-string "%a, %e %b %Y %T %Z" modified)
|
|
httpd-endl))
|
|
(httpd-send-data "Content-Type: text/html; charset=iso-8859-1" httpd-endl
|
|
"Content-Length: " (number-to-string (1- (point-max)))
|
|
httpd-endl httpd-endl
|
|
(buffer-string))
|
|
(httpd-send-eof))
|
|
|
|
(defun muse-http-reject (title msg &optional annotation)
|
|
(muse-with-temp-buffer
|
|
(insert msg ".\n")
|
|
(if annotation
|
|
(insert annotation "\n"))
|
|
(muse-publish-markup-buffer title muse-http-publishing-style)
|
|
(muse-http-send-buffer nil 404 msg)))
|
|
|
|
(defun muse-http-prepare-url (target explicit)
|
|
(save-match-data
|
|
(unless (or (not explicit)
|
|
(string-match muse-url-regexp target)
|
|
(string-match muse-image-regexp target)
|
|
(string-match muse-file-regexp target))
|
|
(setq target (concat "page?" target
|
|
"&project=" muse-http-serving-p))))
|
|
(muse-publish-read-only target))
|
|
|
|
(defun muse-http-render-page (name)
|
|
"Render the Muse page identified by NAME.
|
|
When serving from a dedicated Emacs process (see the httpd-serve
|
|
script), a maximum of `muse-http-max-cache-size' pages will be
|
|
cached in memory to speed up serving time."
|
|
(let ((file (muse-project-page-file name muse-http-serving-p))
|
|
(muse-publish-url-transforms
|
|
(cons 'muse-http-prepare-url muse-publish-url-transforms))
|
|
(inhibit-read-only t))
|
|
(when file
|
|
(with-current-buffer (get-buffer-create file)
|
|
(let ((modified-time (nth 5 (file-attributes file)))
|
|
(muse-publishing-current-file file)
|
|
muse-publishing-current-style)
|
|
(when (or (null muse-buffer-mtime)
|
|
(muse-time-less-p muse-buffer-mtime modified-time))
|
|
(erase-buffer)
|
|
(setq muse-buffer-mtime modified-time))
|
|
(goto-char (point-max))
|
|
(when (bobp)
|
|
(muse-insert-file-contents file t)
|
|
(let ((styles (cddr (muse-project muse-http-serving-p)))
|
|
style)
|
|
(while (and styles (null style))
|
|
(let ((include-regexp
|
|
(muse-style-element :include (car styles)))
|
|
(exclude-regexp
|
|
(muse-style-element :exclude (car styles))))
|
|
(when (and (or (and (null include-regexp)
|
|
(null exclude-regexp))
|
|
(if include-regexp
|
|
(string-match include-regexp file)
|
|
(not (string-match exclude-regexp file))))
|
|
(not (muse-project-private-p file)))
|
|
(setq style (car styles))
|
|
(while (muse-style-element :base style)
|
|
(setq style
|
|
(muse-style (muse-style-element :base style))))
|
|
(if (string= (car style) muse-http-publishing-style)
|
|
(setq style (car styles))
|
|
(setq style nil))))
|
|
(setq styles (cdr styles)))
|
|
(muse-publish-markup-buffer
|
|
name (or style muse-http-publishing-style))))
|
|
(set-buffer-modified-p nil)
|
|
(muse-http-prune-cache)
|
|
(current-buffer))))))
|
|
|
|
(defun muse-http-transmit-page (name)
|
|
"Render the Muse page identified by NAME.
|
|
When serving from a dedicated Emacs process (see the httpd-serve
|
|
script), a maximum of `muse-http-max-cache-size' pages will be
|
|
cached in memory to speed up serving time."
|
|
(let ((inhibit-read-only t)
|
|
(buffer (muse-http-render-page name)))
|
|
(if buffer
|
|
(with-current-buffer buffer
|
|
(muse-http-send-buffer muse-buffer-mtime)))))
|
|
|
|
(defvar httpd-vars nil)
|
|
|
|
(defsubst httpd-var (var)
|
|
"Return value of VAR as a URL variable. If VAR doesn't exist, nil."
|
|
(cdr (assoc var httpd-vars)))
|
|
|
|
(defsubst httpd-var-p (var)
|
|
"Return non-nil if VAR was passed as a URL variable."
|
|
(not (null (assoc var httpd-vars))))
|
|
|
|
(defun muse-http-serve (page &optional content)
|
|
"Serve the given PAGE from this press server."
|
|
;; index.html is really a reference to the project home page
|
|
(if (and muse-project-alist
|
|
(string-match "\\`index.html?\\'" page))
|
|
(setq page (concat "page?"
|
|
(muse-get-keyword :default
|
|
(cadr (car muse-project-alist))))))
|
|
;; handle the actual request
|
|
(let ((vc-follow-symlinks t)
|
|
(muse-publish-report-threshhold nil)
|
|
muse-http-serving-p
|
|
httpd-vars)
|
|
(save-excursion
|
|
;; process any CGI variables, if cgi.el is available
|
|
(if (string-match "\\`\\([^&]+\\)&" page)
|
|
(setq httpd-vars (cgi-decode (substring page (match-end 0)))
|
|
page (match-string 1 page)))
|
|
(unless (setq muse-http-serving-p (httpd-var "project"))
|
|
(let ((project (car muse-project-alist)))
|
|
(setq muse-http-serving-p (car project))
|
|
(setq httpd-vars (cons (cons "project" (car project))
|
|
httpd-vars))))
|
|
(if (and muse-http-serving-p
|
|
(string-match "\\`page\\?\\(.+\\)" page))
|
|
(muse-http-transmit-page (match-string 1 page))))))
|
|
|
|
(if (featurep 'httpd)
|
|
(httpd-add-handler "\\`\\(index\\.html?\\|page\\(\\?\\|\\'\\)\\)"
|
|
'muse-http-serve))
|
|
|
|
(provide 'muse-http)
|
|
|
|
;;; muse-http.el ends here
|