lisp/muse-http.el

   1 ;;; muse-http.el --- publish HTML files over HTTP
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008  Free Software Foundation, Inc.
   4
   5 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   6
   7 ;; Emacs Muse is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published
   9 ;; by the Free Software Foundation; either version 3, or (at your
  10 ;; option) any later version.
  11
  12 ;; Emacs Muse is distributed in the hope that it will be useful, but
  13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;; General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  20 ;; Boston, MA 02110-1301, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Contributors:
  25
  26 ;;; Code:
  27
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;
  30 ;; Publishing HTML over HTTP (using httpd.el)
  31 ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33
  34 (require 'muse-html)
  35 (require 'muse-project)
  36 (require 'httpd)
  37 (require 'cgi)
  38
  39 (defgroup muse-http nil
  40   "Options controlling the behavior of Emacs Muse over HTTP."
  41   :group 'press)
  42
  43 (defcustom muse-http-maintainer (concat "webmaster@" (system-name))
  44   "The maintainer address to use for the HTTP 'From' field."
  45   :type 'string
  46   :group 'muse-http)
  47
  48 (defcustom muse-http-publishing-style "html"
  49   "The style to use when publishing projects over http."
  50   :type 'string
  51   :group 'muse-http)
  52
  53 (defcustom muse-http-max-cache-size 64
  54   "The number of pages to cache when serving over HTTP.
  55 This only applies if set while running the persisted invocation
  56 server.  See main documentation for the `muse-http'
  57 customization group."
  58   :type 'integer
  59   :group 'muse-http)
  60
  61 (defvar muse-buffer-mtime nil)
  62 (make-variable-buffer-local 'muse-buffer-mtime)
  63
  64 (defun muse-sort-buffers (l r)
  65   (let ((l-mtime (with-current-buffer l muse-buffer-mtime))
  66         (r-mtime (with-current-buffer r muse-buffer-mtime)))
  67     (cond
  68      ((and (null l-mtime) (null r-mtime)) l)
  69      ((null l-mtime) r)
  70      ((null r-mtime) l)
  71      (t (muse-time-less-p r-mtime l-mtime)))))
  72
  73 (defun muse-winnow-list (entries &optional predicate)
  74   "Return only those ENTRIES for which PREDICATE returns non-nil."
  75   (let ((flist (list t)))
  76     (let ((entry entries))
  77       (while entry
  78         (if (funcall predicate (car entry))
  79             (nconc flist (list (car entry))))
  80         (setq entry (cdr entry))))
  81     (cdr flist)))
  82
  83 (defun muse-http-prune-cache ()
  84   "If the page cache has become too large, prune it."
  85   (let* ((buflist
  86           (sort (muse-winnow-list (buffer-list)
  87                                   (function
  88                                    (lambda (buf)
  89                                      (with-current-buffer buf
  90                                        muse-buffer-mtime))))
  91                 'muse-sort-buffers))
  92          (len (length buflist)))
  93     (while (> len muse-http-max-cache-size)
  94       (kill-buffer (car buflist))
  95       (setq len (1- len)))))
  96
  97 (defvar muse-http-serving-p nil)
  98
  99 (defun muse-http-send-buffer (&optional modified code msg)
 100   "Markup and send the contents of the current buffer via HTTP."
 101   (httpd-send (or code 200) (or msg "OK")
 102               "Server: muse.el/" muse-version httpd-endl
 103               "Connection: close" httpd-endl
 104               "MIME-Version: 1.0" httpd-endl
 105               "Date: " (format-time-string "%a, %e %b %Y %T %Z")
 106               httpd-endl
 107               "From: " muse-http-maintainer httpd-endl)
 108   (when modified
 109     (httpd-send-data "Last-Modified: "
 110                      (format-time-string "%a, %e %b %Y %T %Z" modified)
 111                      httpd-endl))
 112   (httpd-send-data "Content-Type: text/html; charset=iso-8859-1" httpd-endl
 113                    "Content-Length: " (number-to-string (1- (point-max)))
 114                    httpd-endl httpd-endl
 115                    (buffer-string))
 116   (httpd-send-eof))
 117
 118 (defun muse-http-reject (title msg &optional annotation)
 119   (muse-with-temp-buffer
 120     (insert msg ".\n")
 121     (if annotation
 122         (insert annotation "\n"))
 123     (muse-publish-markup-buffer title muse-http-publishing-style)
 124     (muse-http-send-buffer nil 404 msg)))
 125
 126 (defun muse-http-prepare-url (target explicit)
 127   (save-match-data
 128     (unless (or (not explicit)
 129                 (string-match muse-url-regexp target)
 130                 (string-match muse-image-regexp target)
 131                 (string-match muse-file-regexp target))
 132       (setq target (concat "page?" target
 133                            "&project=" muse-http-serving-p))))
 134   (muse-publish-read-only target))
 135
 136 (defun muse-http-render-page (name)
 137   "Render the Muse page identified by NAME.
 138 When serving from a dedicated Emacs process (see the httpd-serve
 139 script), a maximum of `muse-http-max-cache-size' pages will be
 140 cached in memory to speed up serving time."
 141   (let ((file (muse-project-page-file name muse-http-serving-p))
 142         (muse-publish-url-transforms
 143          (cons 'muse-http-prepare-url muse-publish-url-transforms))
 144         (inhibit-read-only t))
 145     (when file
 146       (with-current-buffer (get-buffer-create file)
 147         (let ((modified-time (nth 5 (file-attributes file)))
 148               (muse-publishing-current-file file)
 149               muse-publishing-current-style)
 150           (when (or (null muse-buffer-mtime)
 151                     (muse-time-less-p muse-buffer-mtime modified-time))
 152             (erase-buffer)
 153             (setq muse-buffer-mtime modified-time))
 154           (goto-char (point-max))
 155           (when (bobp)
 156             (muse-insert-file-contents file t)
 157             (let ((styles (cddr (muse-project muse-http-serving-p)))
 158                   style)
 159               (while (and styles (null style))
 160                 (let ((include-regexp
 161                        (muse-style-element :include (car styles)))
 162                       (exclude-regexp
 163                        (muse-style-element :exclude (car styles))))
 164                   (when (and (or (and (null include-regexp)
 165                                       (null exclude-regexp))
 166                                  (if include-regexp
 167                                      (string-match include-regexp file)
 168                                    (not (string-match exclude-regexp file))))
 169                              (not (muse-project-private-p file)))
 170                     (setq style (car styles))
 171                     (while (muse-style-element :base style)
 172                       (setq style
 173                             (muse-style (muse-style-element :base style))))
 174                     (if (string= (car style) muse-http-publishing-style)
 175                         (setq style (car styles))
 176                       (setq style nil))))
 177                 (setq styles (cdr styles)))
 178               (muse-publish-markup-buffer
 179                name (or style muse-http-publishing-style))))
 180           (set-buffer-modified-p nil)
 181           (muse-http-prune-cache)
 182           (current-buffer))))))
 183
 184 (defun muse-http-transmit-page (name)
 185   "Render the Muse page identified by NAME.
 186 When serving from a dedicated Emacs process (see the httpd-serve
 187 script), a maximum of `muse-http-max-cache-size' pages will be
 188 cached in memory to speed up serving time."
 189   (let ((inhibit-read-only t)
 190         (buffer (muse-http-render-page name)))
 191     (if buffer
 192         (with-current-buffer buffer
 193           (muse-http-send-buffer muse-buffer-mtime)))))
 194
 195 (defvar httpd-vars nil)
 196
 197 (defsubst httpd-var (var)
 198   "Return value of VAR as a URL variable.  If VAR doesn't exist, nil."
 199   (cdr (assoc var httpd-vars)))
 200
 201 (defsubst httpd-var-p (var)
 202   "Return non-nil if VAR was passed as a URL variable."
 203   (not (null (assoc var httpd-vars))))
 204
 205 (defun muse-http-serve (page &optional content)
 206   "Serve the given PAGE from this press server."
 207   ;; index.html is really a reference to the project home page
 208   (if (and muse-project-alist
 209            (string-match "\\`index.html?\\'" page))
 210       (setq page (concat "page?"
 211                          (muse-get-keyword :default
 212                                            (cadr (car muse-project-alist))))))
 213   ;; handle the actual request
 214   (let ((vc-follow-symlinks t)
 215         (muse-publish-report-threshhold nil)
 216         muse-http-serving-p
 217         httpd-vars)
 218     (save-excursion
 219       ;; process any CGI variables, if cgi.el is available
 220       (if (string-match "\\`\\([^&]+\\)&" page)
 221           (setq httpd-vars (cgi-decode (substring page (match-end 0)))
 222                 page (match-string 1 page)))
 223       (unless (setq muse-http-serving-p (httpd-var "project"))
 224         (let ((project (car muse-project-alist)))
 225           (setq muse-http-serving-p (car project))
 226           (setq httpd-vars (cons (cons "project" (car project))
 227                                  httpd-vars))))
 228       (if (and muse-http-serving-p
 229                (string-match "\\`page\\?\\(.+\\)" page))
 230           (muse-http-transmit-page (match-string 1 page))))))
 231
 232 (if (featurep 'httpd)
 233     (httpd-add-handler "\\`\\(index\\.html?\\|page\\(\\?\\|\\'\\)\\)"
 234                        'muse-http-serve))
 235
 236 (provide 'muse-http)
 237
 238 ;;; muse-http.el ends here