muse-http.el

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