;;; arch-htmlify.el --- generate browsable HTML pages of an Arch repository
;; Author: Mark Triggs
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This code generates a browsable web version of a GNU Arch repository.
;; To use it, run M-x arch-html-generate and specify an output directory or
;; evaluate the form (arch-html-generate "my-output-dir" "my-archive") to
;; use a non-default archive.
;; Works great with emacs-wiki! I use this fragment:
;;
;; (ignore (when emacs-wiki-publishing-p
;; (arch-html-generate "/home/mst/projects/site/arch-browse/"
;; "mst@dishevelled.net--2003-mst-MIRROR")))
;;
;; in one of my wiki pages to update my pages during publishing.
;;; Code:
(defvar *arch-htmlify-header* "")
(defvar *arch-htmlify-footer* "")
(defvar *arch-htmlify-style-file* nil)
(defvar *arch-htmlify-style*
"
.parent {margin-top: 20px; margin-bottom: 20px; font-weight: bold}
.revision-summary {margin-top: 15px; margin-left: 5%; margin-right: 5%;
border: solid 1px; padding: 10px; font-size: small}
.creator {font-weight: bold}
.log-header {font-style: italic; margin-bottom: 15px}
.diff-header {font-weight: bold; margin-bottom: 15px}
.diff {margin-left: 5%; margin-right: 5%; border: solid 1px; padding: 10px;
font-size: small}
")
(defvar *arch-cache* '() "Cached arch commands")
(defun arch-htmlify-set= (s1 s2)
(and (subsetp s1 s2 :test 'equal)
(subsetp s2 s1 :test 'equal)))
(defun test (l)
(cons 'list (mapcar
#'(lambda (o)
`(list ,(car o) ,(cadr o)))
l)))
(test '(("foo" "bar") ("qux" "quz")))
(defmacro tla (command options &rest arguments)
`(tla-command ,command
,(cons 'list (mapcar
#'(lambda (o)
`(list ,(car o) ,(cadr o)))
options))
,@arguments))
(defun tla-command (command options &rest arguments)
(let ((cached (find-if
#'(lambda (cache-item)
(let ((cmd-set (car cache-item)))
(and (string= (nth 0 cmd-set)
command)
(arch-htmlify-set= options
(nth 1 cmd-set))
(or (and (null arguments) (null (nth 2 cmd-set)))
(ignore-errors
(equal arguments (nth 2 cmd-set)))))))
*arch-cache*)))
(if cached
(cdr cached)
(let ((output (shell-command-to-string
(format "tla %s %s %s"
command
(mapconcat (lambda (opt)
(if (cadr opt)
(format "%s %s" (car opt)
(cadr opt))
""))
options
" ")
(mapconcat 'identity arguments " ")))))
(push (cons (list command options arguments)
output)
*arch-cache*)
output))))
(defun archive-categories (archive &rest ignored)
(split-string (tla "categories" (("-A" archive)))))
(defun category-branches (category &optional archive)
(split-string (tla "branches" (("-A" archive)) category)))
(defun branch-versions (branch &optional archive)
(split-string (tla "versions" (("-A" archive)) branch)))
(defun version-revisions (version &optional archive)
(mapcar (lambda (r) (format "%s--%s" version r))
(split-string (tla "revisions" (("-A" archive)) version))))
(defun category-tree (category &optional archive)
(mapcar (lambda (b)
(mapcan 'version-revisions (branch-versions b archive)))
(category-branches category)))
(defun revision-creator (revision &optional archive)
(let ((s (find-if (lambda (s) (string-match "Creator: " s))
(split-string (tla "cat-archive-log"
(("-A" archive))
revision)
"\n"))))
(html-despam-address (subseq s (or (1+ (position ? s)) -1)))))
(defun revision-summary (revision &optional archive)
(let ((s (find-if (lambda (s) (string-match "Summary: " s))
(split-string (tla "cat-archive-log"
(("-A" archive))
revision)
"\n"))))
(html-despam-address (subseq s (or (1+ (position ? s)) -1)))))
(defun revision-data (revision &optional archive)
(html-despam-address
(mapconcat (lambda (line)
(if (string-match
(concat "\\(^.*:[ ]*$\\|Summary:\\|"
"Creator:\\| Revision:\\)")
line)
""
(concat line "\n")))
(let ((fields (split-string (tla "cat-archive-log"
(("-A" archive))
revision)
"\n")))
(subseq fields 0 (position "" fields :test 'string=)))
"")))
(defun revision-log (revision &optional archive)
(html-despam-address
(with-temp-buffer
(insert (tla "cat-archive-log" (("-A" archive)) revision))
(goto-char (point-min))
(delete-region (point-min) (1+ (search-forward-regexp "^$" nil t)))
(buffer-string))))
(defun revision-patch-p (revision)
(string-match "--patch-[0-9]+" revision))
(defun get-patch-diff (revision archive)
(if (revision-patch-p revision)
(let* ((revisions (version-revisions
(mapconcat 'identity
(butlast (split-string revision "--"))
"--")
archive))
(previous-revision
(nth (1- (position revision revisions :test 'string=))
revisions)))
(with-temp-buffer
(insert (tla "revdelta" (("--diffs" "")
("-A" archive))
previous-revision
revision))
(goto-char (point-min))
(while (and (not (eobp)) (not (looking-at "^--")))
(kill-line))
(buffer-string)))
nil))
;; Markup
(defun arch-html-generate (output-dir &optional archive)
"Generate HTML markup of an arch archive to a directory"
(interactive "FOutput directory: ")
(setq *arch-cache* '())
(setq archive (or archive (tla "my-default-archive" ())))
(cond ((and (file-exists-p output-dir) (not (file-directory-p output-dir)))
(error "Cannot write to %s!" output-dir))
((not (file-exists-p output-dir)) (make-directory output-dir)))
(let ((tmp (generate-new-buffer "temp")))
(string-to-file (arch-htmlify-archive archive)
(format "%s/index.html" output-dir)
tmp t)
(map nil
(lambda (c)
(string-to-file (arch-htmlify-category c archive (list "index"))
(format "%s/%s.html" output-dir c)
tmp t)
(map nil
(lambda (b)
(string-to-file (arch-htmlify-branch b archive
(list "index" c))
(format "%s/%s.html" output-dir b)
tmp t)
(map nil
(lambda (v)
(string-to-file (arch-htmlify-version
v archive (list "index" c b))
(format "%s/%s.html" output-dir v)
tmp t)
(map nil
(lambda (r)
(string-to-file
(arch-htmlify-revision
r archive (list "index" c b v))
(format "%s/%s.html" output-dir r)
tmp))
(version-revisions v archive)))
(branch-versions b archive)))
(category-branches c archive)))
(archive-categories archive))
(kill-buffer tmp)
(message "Finished generation. Output is in %s" output-dir)))
(defun replace-regexps-in-string (s replacements)
"Replace multiple regexps in S. REPLACEMENTS is an alist of the form
((old1 . new1) (old2 . new2))"
(let ((acc s))
(map nil (lambda (replacement)
(setq acc (replace-regexp-in-string (car replacement)
(cdr replacement) acc)))
replacements)
acc))
(defun html-escape (s)
(replace-regexps-in-string s '(("<" . "<") (">" . ">"))))
(defun html-despam-address (text)
(mapconcat (lambda (s)
(if (string-match "@" s)
(replace-regexps-in-string s '(("\\." . " DOT ")
("@" . " AT ")))
s))
(split-string text " ")
" "))
(defmacro html-tag (name attributes &rest body)
`(format "<%s%s>%s%s>\n"
',name
(if ',attributes
(concat " " (mapconcat
(lambda (tag) (format "%s=%S" (car tag)
(cadr tag)))
(list ,@(mapcar (lambda (a) `(list ,@a))
attributes))
" "))
"")
(concat ,@body)
',name))
(put 'html-tag 'lisp-indent-function 2)
(defmacro arch-html-page (title parent &rest body)
`(html-tag html ()
(html-tag head ()
(html-tag title () ,title)
(if *arch-htmlify-style-file*
(html-tag link (("rel" "stylesheet") ("type" "text/css")
("href" *arch-htmlify-style-file*)))
"")
(html-tag style () *arch-htmlify-style*))
(html-tag body ()
(or *arch-htmlify-header* "")
(html-tag h1 () ,title)
(if parent
(html-tag div (("class" "parent"))
(format "[ %s ]"
(remove (string-to-char "\n")
(mapconcat
(lambda (node)
(arch-html-link (concat node ".html") node))
parent "/"))))
"")
,@body
(or *arch-htmlify-footer* ""))))
(put 'arch-html-page 'lisp-indent-function 2)
(defmacro arch-html-link (href text)
`(html-tag a (("href" ,href)) ,text))
(put 'arch-html-link 'lisp-indent-function 2)
(defmacro def-arch-htmlifier (type header sub-element-fn)
(let ((thing (gensym)))
`(defun ,(intern (format "arch-htmlify-%s" type))
(,type &optional archive parent)
(arch-html-page ,header parent
(html-tag ul ()
(mapconcat (lambda (,thing)
(html-tag li ()
(arch-html-link
(concat ,thing ".html")
,thing)))
(,sub-element-fn ,type archive)
""))))))
(defun arch-htmlify-archive (&optional archive parent)
(arch-html-page (format "Archive: %s"
(html-despam-address
(or archive (tla "my-default-archive" ()))))
parent
(html-tag ul ()
(mapconcat (lambda (cat)
(html-tag li ()
(arch-html-link
(concat cat ".html")
cat)))
(archive-categories archive)
""))))
(def-arch-htmlifier category
(format "Category: %s" category)
category-branches)
(def-arch-htmlifier branch
(format "Branch: %s" branch)
branch-versions)
(defun arch-htmlify-version (version &optional archive parent)
(arch-html-page (format "Version: %s" version) parent
(html-tag p () "Revisions:")
(html-tag ul ()
(mapconcat (lambda (rev)
(html-tag table (("border" "0") ("width" "100%")
("cellspacing" "5px"))
(html-tag tr ()
(html-tag td (("align" "left") ("width" "24%"))
(arch-html-link
(concat rev ".html")
rev))
(html-tag td (("align" "left") ("width" "38%"))
(html-tag i ()
(html-escape (revision-summary rev archive))))
(html-tag td (("align" "left") ("width" "38%"))
(html-tag b ()
(html-escape
(revision-creator rev archive)))))))
(version-revisions version archive)
""))))
(defun arch-htmlify-revision (revision &optional archive parent)
(arch-html-page
(format "Revision: %s" revision) parent
(html-tag div (("class" "revision-summary"))
(html-tag div (("class" "creator"))
(html-escape (revision-creator revision archive)))
(html-tag div (("class" "log-header"))
(html-escape (revision-summary revision archive)))
(html-tag div (("class" "revision-data"))
(html-tag pre (("width" "100%"))
(html-escape
(revision-data revision archive))))
(html-tag div (("class" "log-entry"))
(html-tag pre (("width" "100%"))
(html-escape (revision-log revision archive)))))
(let ((diff (get-patch-diff revision archive)))
(when diff
(html-tag p () (html-tag div (("class" "diff-header"))
"Diff output:")
(html-tag div (("class" "diff"))
(html-tag pre (("width" "100%"))
(html-escape diff))))))))
;; Utils
(defmacro string-to-file (s file &optional temp-buffer clobber)
`(unless (and (file-exists-p ,file) (not ,clobber))
(if ,temp-buffer
(with-current-buffer ,temp-buffer
(delete-region (point-min) (point-max))
(insert ,s)
(write-file ,file))
(with-temp-buffer
(insert ,s)
(write-file ,file)))))
(provide 'arch-htmlify)
;;; arch-htmlify.el ends here