;;; gpgweb.el --- elisp helper code for the GnuPG web pages (if (< (string-to-number emacs-version) 24) (require 'org-exp)) ;; makeindex disabled because the generated file is created in the ;; source directory. (defun gpgweb-setup-project () "Set up an org-publish project for the gnupg.org website." (progn (require 'ox-gpgweb (concat gpgweb-root-dir "share/ox-gpgweb.el")) (aput 'org-publish-project-alist "gpgweb-org" `(:base-directory ,gpgweb-root-dir :base-extension "org" :language "en" :html-extension "html" :recursive t :publishing-directory ,gpgweb-stage-dir :publishing-function gpgweb-org-to-html :body-only t :section-numbers nil :tags nil :with-toc nil :makeindex nil :auto-sitemap nil :sitemap-title "GnuPG - Sitemap" :sitemap-sort-folders "last" :sitemap-file-entry-format "%t @@html:@@(%d)@@html:@@" :style-include-default nil :timestamp-file nil :html-head "" :html-head-include-scripts nil)) (aput 'org-publish-project-alist "gpgweb-other" `(:base-directory ,gpgweb-root-dir :base-extension "jpg\\|png\\|css\\|txt\\|rss\\|lst\\|sig\\|js\\|map\\|eot\\|ttf\\|woff\\|woff2\\|svg" :recursive t :publishing-directory ,gpgweb-stage-dir :publishing-function org-publish-attachment :completion-function gpgweb-upload)) (aput 'org-publish-project-alist "gpgweb" '(:components ("gpgweb-org" "gpgweb-other"))) (add-hook 'org-export-before-processing-hook 'gpgweb-preprocess))) (defun gpgweb-preprocess (backend) "Insert certain stuff before processing." (let () (goto-char (point-min)) (when (re-search-forward "^#\\+GPGWEB-NEED-SWDB\\b" 2048 t) (beginning-of-line) (kill-line 1) (insert (org-file-contents (concat gpgweb-root-dir "swdb.mac") 'noerror))))) (defun gpgweb-insert-header (title committed-at custom) "Insert the header. COMMITTED-AT is the commit date string of the source file or nil if not available. If CUSTOM is true only a minimal header is set." (goto-char (point-min)) (insert " " title " ") (when (and committed-at (>= (length committed-at) 10)) (insert "\n")) (insert " ") (unless custom (insert " "))) (defconst gpgweb-gnupg-menu-alist '(("/index.html" "Home" (("/index.html" "Home") ("/news.html" "News") ("/people/index.html" "People") ("/verein/index.html" "Verein") ("/documentation/sites.html" "Sites"))) ("/donate/index.html" "Donate" (("/donate/index.html" "Donate") ("/donate/kudos.html" "List of Donors"))) ("/software/index.html" "Software" (("/software/index.html" "GnuPG") ("/software/frontends.html" "Frontends") ("/software/tools.html" "Tools") ("/software/libraries.html" "Libraries") ("/software/swlist.html" "All"))) ("/download/index.html" "Download" (("/download/index.html" "Download") ("/download/integrity_check.html" "Integrity Check") ("/download/supported_systems.html" "Supported Systems") ("/download/release_notes.html" "Release Notes") ("/download/mirrors.html" "Mirrors") ("/download/git.html" "GIT"))) ("/documentation/index.html" "Documentation" (("/documentation/howtos.html" "HOWTOs") ("/documentation/manuals.html" "Manuals") ("/documentation/guides.html" "Guides") ("/documentation/faqs.html" "FAQs") ("/documentation/mailing-lists.html" "Mailing Lists") ("/service.html" "3rd Party Support") ("/documentation/bts.html" "Bug Tracker") ("/documentation/security.html" "Security"))) ("/blog/index.html" "Blog")) "The definition of the gnupg.org menu structure.") (defconst gpgweb-gnupg-bottom-menu-alist '(("/privacy-policy.html" "Privacy Policy" ()) ("/imprint.html" "Imprint" ()) ("/misc/index.html" "Archive" ()) ("/sitemap.html" "Sitemap" ()) ("/blog/index.html" "Blog" ())) "The definition of the gnupg.org bottom menu structure.") (defun gpgweb--any-selected-menu-p (menu selected-file) "Return t if any item in MENU has been selected." (let ((item (car menu)) res) (when menu (when item (when (string= (car item) selected-file) (setq res t)) (when (caddr item) (when (gpgweb--any-selected-menu-p (caddr item) selected-file) (setq res t)))) (when (gpgweb--any-selected-menu-p (cdr menu) selected-file) (setq res t))) res)) (defun gpgweb--selected-top-menu (menu selected-file) "Return the selected top menu or nil." (when menu (let ((item (car menu))) (if (and item (or (string= (car item) selected-file) (gpgweb--any-selected-menu-p (caddr item) selected-file))) menu (gpgweb--selected-top-menu (cdr menu) selected-file))))) (defun gpgweb--insert-menu (menu lvl selected-file) "Helper function to insert the menu." (when menu (let ((item (car menu))) (when item (dotimes (i (1+ lvl)) (insert " ")) (insert "
  • " (cadr item) "\n") (when (caddr item) (dotimes (i (1+ lvl)) (insert " ")) (insert " \n")) (dotimes (i (1+ lvl)) (insert " ")) (insert "
  • \n"))) (gpgweb--insert-menu (cdr menu) lvl selected-file))) (defun gpgweb--insert-submenu (menu selected-file) "Helper function to insert the sub-menu." (when menu (let ((item (car menu))) (when item (insert "
  • " (cadr item) "
  • \n"))) (gpgweb--insert-submenu (cdr menu) selected-file))) (defun gpgweb-insert-menu (selected-file) "Insert the menu structure into the HTML file." (goto-char (point-min)) (when (re-search-forward "^\n" nil t) (insert "
     
    ") (let ((m (caddr (car (gpgweb--selected-top-menu gpgweb-gnupg-menu-alist selected-file))))) (when m (insert "\n"))) (insert "
    "))) (defun gpgweb-blog-index (orgfile filelist) "Return the index of ORGFILE in FILELIST or nil if not found." (let (found (i 0)) (while (and filelist (not found)) (if (string= orgfile (car filelist)) (setq found i)) (setq i (1+ i)) (setq filelist (cdr filelist))) found)) (defun gpgweb-blog-prev (fileidx filelist) "Return the chronological previous file at FILEIDX from FILELIST with the suffixed replaced by \"html\"." (if (> fileidx 1) (concat (file-name-sans-extension (nth (1- fileidx) filelist)) ".html"))) (defun gpgweb-blog-next (orgfile filelist) "Return the chronological next file at FILEIDX from FILELIST with the suffixed replaced by \"html\"." (if (< fileidx (1- (length filelist))) (concat (file-name-sans-extension (nth (1+ fileidx) filelist)) ".html"))) (defun gpgweb-fixup-blog (info orgfile filelist) "Insert the blog specific content. INFO is the usual plist. ORGFILE is the name of the current source file without the directory part. If FILELIST is a list it has an ordered list of org filenames." (let ((authorstr (car (plist-get info :author))) (datestr (car (plist-get info :date)))) (goto-char (point-min)) (if (re-search-forward "^
    " nil t) (let* ((indexp (string= orgfile "index.org")) (fileidx (if (listp filelist) (if indexp (1- (length filelist)) (gpgweb-blog-index orgfile filelist)))) (prevfile (if fileidx (gpgweb-blog-prev fileidx filelist))) (nextfile (if (and fileidx (not indexp)) (gpgweb-blog-next fileidx filelist)))) (move-beginning-of-line nil) (insert "\n"))) (if (and datestr authorstr) (if (re-search-forward "^

    Posted " datestr " by " authorstr "

    \n"))))) (defun gpgweb-insert-footer (htmlfile committed-at blogmode) "Insert the footer. HTMLFILE is HTML file name and COMMITTED-AT is the commit date string of the source file or nil if not available." (let ((srcfile (concat "https://git.gnupg.org/cgi-bin/gitweb.cgi?" "p=gnupg-doc.git;a=blob;f=" (if blogmode "misc/blog.gnupg.org" "web/") ;; The replace below is a hack to cope with ;; blogmode where HTMLFILE is like "./foo.html". (replace-regexp-in-string "^\\./" "/" (file-name-sans-extension htmlfile) t) ".org")) (changed (if (and committed-at (>= (length committed-at) 10)) (substring committed-at 0 10) "[unknown]"))) (goto-char (point-max)) (insert "

      ") (gpgweb--insert-menu gpgweb-gnupg-bottom-menu-alist 0 nil) (insert "
    ") (insert "
    \"Traueranzeige:

    ") (goto-char (point-min)) (unless (search-forward "" nil t) (goto-char (point-max)) (insert "
    \"CC-BY-SA  These web pages are Copyright 1998--2017 The GnuPG Project and licensed under a Creative Commons Attribution-ShareAlike 3.0 Unported License. See copying for details. Page source last changed on " changed ".
    \n")) (goto-char (point-max)) (insert "
    "))) (defun gpgweb-publish-find-title (file &optional reset) "Find the title of FILE in project. This is a copy of org-publish-find-title which switches the buffer into read-write mode so that it works with read-only files." (or (and (not reset) (org-publish-cache-get-file-property file :title nil t)) (let* ((org-inhibit-startup t) (visiting (find-buffer-visiting file)) (buffer (or visiting (find-file-noselect file)))) (with-current-buffer buffer (toggle-read-only 0) (let ((title (let ((property (plist-get ;; protect local variables in open buffers (if visiting (org-export-with-buffer-copy (org-export-get-environment)) (org-export-get-environment)) :title))) (if property (org-no-properties (org-element-interpret-data property)) (file-name-nondirectory (file-name-sans-extension file)))))) (unless visiting (kill-buffer buffer)) (org-publish-cache-set-file-property file :title title) title))))) (defun gpgweb-want-custom-page-p () "Return true if the current buffer indicated that it wants to be a custom page." (let ((savepoint (point)) (result)) (goto-char (point-min)) (setq result (not (not (search-forward "" nil t)))) (goto-char savepoint) result)) (defun gpgweb-postprocess-html (plist orgfile htmlfile blogmode) "Post-process the generated HTML file - Insert header and footer - Insert \"class=selected\" into the active menu entry - Fixup sitemap. If blogmode is not nil the output is rendered as a blog. BLOGMODE may then contain an ordered list of org file names which are used to create the previous and Next links for an entry." (let* ((visitingp (find-buffer-visiting htmlfile)) (work-buffer (or visitingp (find-file-noselect htmlfile))) (committed-at (shell-command-to-string (concat "git" (if blogmode (concat " -C " gpgweb-blog-dir)) " log -1 --format='%ci' -- " orgfile)))) (prog1 (with-current-buffer work-buffer (let ((fname (file-name-nondirectory htmlfile)) (fname-2 (replace-regexp-in-string ".*/gnupg-doc-stage/web/\\(.*\\)$" "\\1" htmlfile t)) (title (gpgweb-publish-find-title orgfile)) (custom (gpgweb-want-custom-page-p))) ;; Insert header, menu, and footer. (gpgweb-insert-header title committed-at custom) (unless custom (goto-char (point-min)) (unless (search-forward "" nil t) (gpgweb-insert-menu fname-2)) (if blogmode (gpgweb-fixup-blog plist (file-name-nondirectory orgfile) blogmode)) (gpgweb-insert-footer fname-2 committed-at blogmode)) ; Fixup the sitemap (when (string-equal fname "sitemap.html") (goto-char (point-min)) (while (re-search-forward "^.*
  • .*>\\(GnuPG - \\).* and ; attributes. (goto-char (point-min)) (when (search-forward "" nil t) (goto-char (point-min)) (while (re-search-forward "^