X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/108d6d47a903cff5d7ac7d83f126dda209c3eeb2..b717b0ee04ffdfd6c44c24cec77ef464fa8d4b95:/packages/muse/muse-http.el diff --git a/packages/muse/muse-http.el b/packages/muse/muse-http.el new file mode 100644 index 000000000..40bd1cb49 --- /dev/null +++ b/packages/muse/muse-http.el @@ -0,0 +1,239 @@ +;;; 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