;;; arch-htmlify.el --- generate browsable HTML pages of an Arch repository

;; Author: Mark Triggs <mst@dishevelled.net>

;; 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:

;; <lisp>
;; (ignore (when emacs-wiki-publishing-p
;;           (arch-html-generate "/home/mst/projects/site/arch-browse/"
;;                               "mst@dishevelled.net--2003-mst-MIRROR")))
;; </lisp>

;; 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 '(("<" . "&lt;") (">" . "&gt;"))))

(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