muse-http.el

;;; muse-http.el --- Publish HTML files over HTTP.

;; Copyright (C) 2004, 2005  Free Software Foundation, Inc.

;; This file is not part of GNU Emacs.

;; This 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 2, or (at your option) any later
;; version.
;;
;; This 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 GNU Emacs; 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)
            (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