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