New XHTML style, add more examples to my sample muse config
[muse-el.git] / muse-http.el
blob808aaf961de398eb7e783fefeadc5d1a7f45d382
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;
3 ;; Publishing HTML over HTTP (using httpd.el)
4 ;;
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 (require 'muse-html)
8 (require 'muse-project)
9 (require 'httpd)
10 (require 'cgi)
12 (defgroup muse-http nil
13 "Options controlling the behaviour of Emacs Muse over HTTP."
14 :group 'press)
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)
21 (defcustom muse-http-publishing-style "html"
22 "The style to use when publishing projects over http."
23 :type 'string
24 :group 'muse-http)
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)
34 (defvar muse-buffer-mtime nil)
35 (make-variable-buffer-local 'muse-buffer-mtime)
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)))))
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)))
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)))))
71 (defvar muse-http-serving-p nil)
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))
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)))
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))
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))))))
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)))))
168 (defvar httpd-vars nil)
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)))
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))))
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))))))
205 (if (featurep 'httpd)
206 (httpd-add-handler "\\`\\(index\\.html?\\|page\\(\\?\\|\\'\\)\\)"
207 'muse-http-serve))
209 (provide 'muse-http)
211 ;;; muse-http.el ends here