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