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