code.delx.au - gnu-emacs-elpa/blob - packages/muse/muse-http.el

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