web: Prepare for auto-builder
[gnupg-doc.git] / web / share / gpgweb.el
1 ;;; gpgweb.el --- elisp helper code for the GnuPG web pages
2
3 (require 'org-exp)
4
5 (defun gpgweb-setup-project ()
6   "Set up an org-publish project for the gnupg.org website."
7   (progn
8    (require 'ox-gpgweb (concat gpgweb-root-dir "share/ox-gpgweb.el"))
9    (aput 'org-publish-project-alist "gpgweb-org"
10    `(:base-directory ,gpgweb-root-dir
11      :base-extension "org"
12      :language "en"
13      :html-extension "html"
14      :recursive t
15      :publishing-directory ,gpgweb-stage-dir
16      :publishing-function gpgweb-org-to-html
17      :body-only t
18      :section-numbers nil
19      :tags nil
20      :with-toc nil
21      :makeindex t
22      :auto-sitemap nil
23      :sitemap-title "GnuPG - Sitemap"
24      :sitemap-sort-folders "last"
25      :sitemap-file-entry-format "%t  @@html:<span id=\"smallnote\">@@(%d)@@html:</span>@@"
26      :style-include-default nil
27      :timestamp-file nil
28      :html-head "<link rel=\"stylesheet\" href=\"gnupg.css\" type=\"text/css\" />"
29      :html-head-include-scripts nil))
30
31    (aput 'org-publish-project-alist "gpgweb-other"
32    `(:base-directory ,gpgweb-root-dir
33      :base-extension "jpg\\|png\\|css\\|txt\\|rss\\|lst\\|sig"
34      :recursive t
35      :publishing-directory ,gpgweb-stage-dir
36      :publishing-function org-publish-attachment
37      :completion-function gpgweb-upload))
38
39    (aput 'org-publish-project-alist "gpgweb"
40    '(:components ("gpgweb-org" "gpgweb-other")))
41
42    (add-hook 'org-export-before-processing-hook 'gpgweb-preprocess)))
43
44
45 (defun gpgweb-preprocess (backend)
46   "Insert certain stuff before processing."
47   (let ()
48     (goto-char (point-min))
49     (when (re-search-forward
50            "^#\\+GPGWEB-NEED-SWDB\\b" 2048 t)
51       (beginning-of-line)
52       (kill-line 1)
53       (insert (org-file-contents (concat gpgweb-root-dir "swdb.mac")
54                                  'noerror)))))
55
56
57 (defun gpgweb-insert-header (title committed-at)
58   "Insert the header.
59
60 COMMITTED-AT is the commit date string of the source file or nil
61 if not available."
62   (goto-char (point-min))
63   (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>
64 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
65                \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
66 <html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en\" xml:lang=\"en\">
67 <head>
68 <title>" title "</title>
69 <meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />\n")
70   (when (and committed-at (>= (length committed-at) 10))
71       (insert "<meta name=\"DC.Date\" content=\""
72               (substring committed-at 0 10) "\" />\n"))
73   (insert "<meta name=\"DC.Language\" content=\"en\" />
74 <meta name=\"DC.Title\" content=\"" title "\" />
75 <meta name=\"DC.Description\"
76  content=\"GnuPG is a free implementation of OpenPGP\" />
77 <meta name=\"DC.Creator\" content=\"The People of the GnuPG Project\" />
78 <meta name=\"DC.Publisher\" content=\"The GnuPG Project\" />
79 <meta name=\"DC.Identifier\" content=\"https://gnupg.org/\" />
80 <meta name=\"DC.Rights\" content=\"https://gnupg.org/copying.html\" />
81 <link rel=\"stylesheet\" href=\"/share/site.css\" type=\"text/css\" />
82 </head>
83 <body>
84 "))
85
86 (defconst gpgweb-gnupg-menu-alist
87   '(("/index.html"
88      "Home"
89      (("/index.html"                       "Home")
90       ("/features.html"                    "Features")
91       ("/news.html"                        "News")
92       ("/people/index.html"                "People")
93       ("/documentation/sites.html"         "Sites")
94       ("/service.html"                     "Service")))
95     ("/donate/index.html"
96      "Donate"
97      (("/donate/index.html"                "Donate")
98       ("/donate/kudos.html"                "List of Donors")))
99     ("/download/index.html"
100      "Download"
101      (("/download/index.html"              "Download")
102       ("/download/integrity_check.html"    "Integrity&nbsp;Check")
103       ("/download/supported_systems.html"  "Supported&nbsp;Systems")
104       ("/download/release_notes.html"      "Release&nbsp;Notes")
105       ("/download/mirrors.html"            "Mirrors")
106       ("/download/cvs_access.html"         "GIT")))
107     ("/documentation/index.html"
108      "Support"
109      (("/documentation/howtos.html"        "HOWTOs")
110       ("/documentation/manuals.html"       "Manuals")
111       ("/documentation/guides.html"        "Guides")
112       ("/documentation/faqs.html"          "FAQs")
113       ("/documentation/mailing-lists.html" "Mailing&nbsp;Lists")
114       ("/documentation/bts.html"           "Bug&nbsp;Tracker")
115       ("/documentation/security.html"      "Security")))
116     ("/related_software/index.html"
117      "Related software"
118      (("/related_software/frontends.html"  "Frontends")
119       ("/related_software/tools.html"      "Tools")
120       ("/related_software/libraries.html"  "Libraries")
121       ("/related_software/swlist.html"     "All")))
122     ("/blog/index.html"
123      "Blog"))
124   "The definition of the gnupg.org menu structure.")
125
126 (defconst gpgweb-gnupg-bottom-menu-alist
127   '(("/privacy-policy.html"
128      "Privacy&nbsp;Policy"
129      ())
130     ("/imprint.html"
131      "Imprint"
132      ())
133     ("/misc/index.html"
134      "Archive"
135      ())
136     ("/sitemap.html"
137      "Sitemap"
138      ())
139     ("/blog/index.html"
140      "Blog"
141      ()))
142   "The definition of the gnupg.org bottom menu structure.")
143
144
145 (defun gpgweb--any-selected-menu-p (menu selected-file)
146   "Return t if any item in MENU has been selected."
147   (let ((item (car menu))
148         res)
149     (when menu
150       (when item
151         (when (string= (car item) selected-file)
152             (setq res t))
153         (when (caddr item)
154           (when (gpgweb--any-selected-menu-p (caddr item) selected-file)
155             (setq res t))))
156       (when (gpgweb--any-selected-menu-p (cdr menu) selected-file)
157         (setq res t)))
158     res))
159
160
161 (defun gpgweb--selected-top-menu (menu selected-file)
162   "Return the selected top menu or nil."
163   (when menu
164     (let ((item (car menu)))
165       (if (and item
166                (or (string= (car item) selected-file)
167                    (gpgweb--any-selected-menu-p (caddr item) selected-file)))
168           menu
169         (gpgweb--selected-top-menu (cdr menu) selected-file)))))
170
171 (defun gpgweb--insert-menu (menu lvl selected-file)
172   "Helper function to insert the menu."
173   (when menu
174     (let ((item (car menu)))
175       (when item
176         (dotimes (i (1+ lvl)) (insert "  "))
177         (insert "  <li><a href=\"" (car item) "\"")
178         (when (or (string= (car item) selected-file)
179                   (gpgweb--any-selected-menu-p (caddr item) selected-file))
180           (insert " class=\"selected\""))
181         (insert  ">" (cadr item) "</a>\n")
182         (when (caddr item)
183           (dotimes (i (1+ lvl)) (insert "  "))
184           (insert "  <ul class=\"sub-menu\">\n")
185           (gpgweb--insert-menu (caddr item) (1+ lvl) selected-file)
186           (dotimes (i (1+ lvl)) (insert "  "))
187           (insert "  </ul>\n"))
188         (dotimes (i (1+ lvl)) (insert "  "))
189         (insert "  </li>\n")))
190     (gpgweb--insert-menu (cdr menu) lvl selected-file)))
191
192
193 (defun gpgweb--insert-submenu (menu selected-file)
194    "Helper function to insert the sub-menu."
195    (when menu
196      (let ((item (car menu)))
197        (when item
198          (insert "    <li><a href=\"" (car item) "\"")
199          (when (or (string= (car item) selected-file)
200                    (gpgweb--any-selected-menu-p (caddr item) selected-file))
201            (insert " class=\"selected\""))
202          (insert ">" (cadr item) "</a></li>\n")))
203      (gpgweb--insert-submenu (cdr menu) selected-file)))
204
205
206 (defun gpgweb-insert-menu (selected-file)
207   "Insert the menu structure into the HTML file."
208   (goto-char (point-min))
209   (when (re-search-forward "^<body>\n" nil t)
210     (insert "<div id=\"wrapper\">
211 <div id=\"header\"><a href=\"/index.html\" class=\"logo\"
212      ><img src=\"/share/logo-gnupg-light-purple-bg.png\"></a>&nbsp;</div>
213 <nav>
214   <ul>
215 ")
216     (gpgweb--insert-menu gpgweb-gnupg-menu-alist 0 selected-file)
217     (insert "  </ul>
218 </nav>
219 ")
220     (let ((m (caddr (car (gpgweb--selected-top-menu
221                           gpgweb-gnupg-menu-alist selected-file)))))
222       (when m
223           (insert "<nav class=\"subnav\">\n  <ul>\n")
224           (gpgweb--insert-submenu m selected-file)
225           (insert "  </ul>\n</nav>\n")))
226     (insert "<main>
227 <div id=\"content\">
228 ")))
229
230
231 (defun gpgweb-blog-index (orgfile filelist)
232   "Return the index of ORGFILE in FILELIST or nil if not found."
233   (let (found
234         (i 0))
235     (while (and filelist (not found))
236       (if (string= orgfile (car filelist))
237           (setq found i))
238       (setq i (1+ i))
239       (setq filelist (cdr filelist)))
240     found))
241
242 (defun gpgweb-blog-prev (fileidx filelist)
243   "Return the chronological previous file at FILEIDX from FILELIST
244 with the suffixed replaced by \"html\"."
245   (if (> fileidx 1)
246       (concat (file-name-sans-extension (nth (1- fileidx) filelist)) ".html")))
247
248 (defun gpgweb-blog-next (orgfile filelist)
249   "Return the chronological next file at FILEIDX from FILELIST
250 with the suffixed replaced by \"html\"."
251   (if (< fileidx (1- (length filelist)))
252       (concat (file-name-sans-extension (nth (1+ fileidx) filelist)) ".html")))
253
254 (defun gpgweb-fixup-blog (info orgfile filelist)
255   "Insert the blog specific content.  INFO is the usual
256 plist. ORGFILE is the name of the current source file without the
257 directory part.  If FILELIST is a list it has an ordered list of
258 org filenames."
259   (let ((authorstr (car (plist-get info :author)))
260         (datestr   (car (plist-get info :date))))
261     (goto-char (point-min))
262     (if (re-search-forward "^<main>" nil t)
263         (let* ((indexp (string= orgfile "index.org"))
264                (fileidx (if (listp filelist)
265                             (if indexp
266                                 (1- (length filelist))
267                               (gpgweb-blog-index orgfile filelist))))
268                (prevfile (if fileidx
269                              (gpgweb-blog-prev fileidx filelist)))
270                (nextfile (if (and fileidx (not indexp))
271                            (gpgweb-blog-next fileidx filelist))))
272           (move-beginning-of-line nil)
273           (insert "<nav class=\"subnav\">\n  <ul>\n")
274           (if prevfile
275               (insert "    <li><a href=\"" prevfile "\">Previous</a></li>\n"))
276           (insert
277            "    <li><a href=\"/blog/index.html#blogindex\">Index</a></li>\n")
278           (if nextfile
279               (insert "    <li><a href=\"" nextfile "\">Next</a></li>\n"))
280           (insert "  </ul>\n</nav>\n")))
281     (if (and datestr authorstr)
282         (if (re-search-forward "^<h2 id=.*\n" nil t)
283             (insert "<p class=\"postdate\">Posted "
284                     datestr
285                     " by "
286                     authorstr
287                     "</p>\n")))))
288
289
290 (defun gpgweb-insert-footer (htmlfile committed-at blogmode)
291   "Insert the footer.
292
293 HTMLFILE is HTML file name and COMMITTED-AT is the commit date
294 string of the source file or nil if not available."
295   (let ((srcfile (concat "https://git.gnupg.org/cgi-bin/gitweb.cgi?"
296                          "p=gnupg-doc.git;a=blob;f="
297                          (if blogmode "misc/blog.gnupg.org" "web")
298                          ;; The replace below is a hack to cope with
299                          ;; blogmode where HTMLFILE is like "./foo.html".
300                          (replace-regexp-in-string
301                           "^\\./" "/"
302                           (file-name-sans-extension htmlfile) t)
303                          ".org"))
304         (changed (if (and committed-at (>= (length committed-at) 10))
305                      (substring committed-at 0 10)
306                      "[unknown]")))
307     (goto-char (point-max))
308     (insert "</div><!-- end content -->
309 </main>
310 <div id=\"footer\">
311   <div id=\"nav_bottom\">
312   <ul>
313 ")
314     (gpgweb--insert-menu gpgweb-gnupg-bottom-menu-alist 0 nil)
315     (insert "    </ul>
316   </div>
317 ")
318     (insert "  <div class=\"footerbox\">
319   <a><img src=\"/share/traueranzeige-g10_v2015.png\"
320           width=\"200px\" height=\"73px\"
321           alt=\"Traueranzeige: Wir nehmen Abschied von einem sicher geglaubten Freund, dem | Fernmeldegeheimniss | (Artikel 10 Grundgesetz) | * 23. Mai 1949, + 18. Dezember 2015\"
322           title=\"Article 10 of the German constitution (communication privacy) is not anymore with us.\" /></a>
323   <p></p>
324   </div>
325 ")
326     (goto-char (point-min))
327     (unless (search-forward "<!--disable-copyright-footer-->" nil t)
328       (goto-char (point-max))
329       (insert "  <div id=\"cpyright\">
330     <a rel=\"license\" href=\"http://creativecommons.org/licenses/by-sa/3.0/\"
331       ><img alt=\"CC-BY-SA 3.0\" style=\"border: 0\"
332             src=\"/share/cc-by-sa-3.0_80x15.png\"/></a>&nbsp;
333     These web pages are
334     Copyright 1998--2015 The GnuPG Project and licensed under a
335     <a rel=\"license\" href=\"http://creativecommons.org/licenses/by-sa/3.0/\"
336     >Creative Commons Attribution-ShareAlike 3.0 Unported License</a>.  See
337     <a href=\"/copying.html\">copying</a> for details.
338     Page <a href=\"" srcfile "\">source</a> last changed on " changed ".
339   </div>\n"))
340   (goto-char (point-max))
341   (insert "</div>
342 </div><!-- end wrapper -->
343 </body>
344 </html>")))
345
346
347 ;;; Post-process the generated HTML file:
348 ;;;
349 ;;; - Insert header and footer
350 ;;; - Insert "class=selected" into the active menu entry
351 ;;; - Fixup sitemap.
352 ;;;
353 ;;; If blogmode is not nil the output is rendered as a blog.  BLOGMODE
354 ;;; may then contain an ordered list of org file names which are used
355 ;;; to create the previous and Next links for an entry.
356 ;;;
357 (defun gpgweb-postprocess-html (plist orgfile htmlfile blogmode)
358   (let* ((visitingp (find-buffer-visiting htmlfile))
359          (work-buffer (or visitingp (find-file-noselect htmlfile)))
360          (committed-at (shell-command-to-string
361                         (concat "git log -1 --format='%ci' -- " orgfile))))
362     (prog1 (with-current-buffer work-buffer
363              (let ((fname (file-name-nondirectory htmlfile))
364                    (fname-2 (replace-regexp-in-string
365                               ".*/gpgweb-stage\\(/.*\\)$" "\\1" htmlfile t))
366                    (title (org-publish-find-title orgfile)))
367                ;; Insert header, menu, and footer.
368                (gpgweb-insert-header title committed-at)
369                (gpgweb-insert-menu fname-2)
370                (if blogmode
371                    (gpgweb-fixup-blog plist
372                                       (file-name-nondirectory orgfile)
373                                       blogmode))
374                (gpgweb-insert-footer fname-2 committed-at blogmode)
375
376                ; Fixup the sitemap
377                (when (string-equal fname "sitemap.html")
378                  (goto-char (point-min))
379                  (while (re-search-forward
380                          "^.*<li>.*>\\(GnuPG - \\).*<span.*$" nil t)
381                    (replace-match "" t nil nil 1)))
382
383                ; Due to a problem with the current org exporter (cases
384                ; were we link to file mapped via a webserver alias) we
385                ; have to use a full URL at some places in the org
386                ; source.  We fix that up here.
387                (goto-char (point-min))
388                (while (re-search-forward
389                        "href=\"\\(https://www.gnupg.org\\)/.*\"" nil t)
390                  (replace-match "" t t nil 1))
391
392                ; If the wideright flag is used, change <td> and <th>
393                ; attributes.
394                (goto-char (point-min))
395                (when (search-forward "<!--table_data_wideright-->" nil t)
396                  (goto-char (point-min))
397                  (while (re-search-forward
398                          "^<t[hd].*class=\"\\(right\\)\".*$" nil t)
399                    (replace-match "right wideright" t nil nil 1)))
400
401                ; And save the changes
402                (basic-save-buffer))
403       (unless visitingp (kill-buffer work-buffer))))))
404
405
406 ;;;
407 ;;; The publishing function used by the HTML exporter
408 ;;;
409 (defun gpgweb-org-to-html (plist filename pub-dir)
410   (gpgweb-postprocess-html plist
411                            filename
412                            (org-gpgweb-publish-to-html plist filename pub-dir)
413                            nil))
414
415
416 ;;;
417 ;;; Turn the current buffer which has an org-mode blog entry into its
418 ;;; rendered form and save it with the suffix .html.
419 ;;;
420 (defun gpgweb-render-blog (&optional filelist)
421   (interactive)
422   (let* ((extplist '(:language "en"
423                      :section-numbers nil
424                      :tags nil
425                      :with-toc nil))
426          (orgfile (buffer-file-name))
427          (plist (org-export-get-environment 'gpgweb nil extplist))
428          (htmlfile (org-gpgweb-export-to-html nil nil nil t extplist)))
429     (gpgweb-postprocess-html plist orgfile htmlfile (if filelist filelist t))))
430
431
432 ;;;
433 ;;; Publish all blog entries in the current directory
434 ;;;
435 (defun gpgweb-publish-blogs ()
436   (interactive)
437   (let ((orgfiles (directory-files "." nil "^2[0-9]+-.*\.org$")))
438     (dolist (file (cons "index.org" orgfiles))
439       (let* ((visitingp (find-buffer-visiting file))
440              (work-buffer (or visitingp (find-file-noselect file))))
441         (with-current-buffer work-buffer
442           (gpgweb-render-blog orgfiles)
443           (basic-save-buffer))
444         (unless visitingp
445           (kill-buffer work-buffer))))))
446
447
448 ;;;
449 ;;; We don't do an upload directly.  Instead we only print the
450 ;;; commands to do that.  In reality a cron jobs syncs the stage dir.
451 ;;;
452 (defun gpgweb-upload ()
453   (let ((stagedir (plist-get project-plist :publishing-directory)))
454     (message "gpgweb  rootdir '%s'" gpgweb-root-dir)
455     (message "gpgweb stagedir '%s'" stagedir)
456     (message
457      (concat "cd " gpgweb-root-dir " && cd " stagedir
458              " && echo rsync -rlt --exclude \"*~\" ./ "
459              "werner@trithemius.gnupg.org:"
460              "/var/www/www/www.gnupg.org/htdocs/ ;"
461              " echo ssh werner@trithemius.gnupg.org"
462              " touch /var/www/www/www.gnupg.org/htdocs/donate/donors.dat"))
463 ))
464
465 (provide 'gpgweb)