#!/usr/local/bin/gosh
;;; manual-index - simple index.html generator
;;;
;;;  Copyright (c) 2005-2006 OOHASHI Daichi, All rights reserved.
;;;
;;;  Redistribution and use in source and binary forms, with or without
;;;  modification, are permitted provided that the following conditions
;;;  are met:
;;;
;;;  1. Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;  2. Redistributions in binary form must reproduce the above copyright
;;;     notice, this list of conditions and the following disclaimer in the
;;;     documentation and/or other materials provided with the distribution.
;;;
;;;  3. Neither the name of the authors nor the names of its contributors
;;;     may be used to endorse or promote products derived from this
;;;     software without specific prior written permission.
;;;
;;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;  OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;  TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(use srfi-1)
(use srfi-11)
(use srfi-13)
(use srfi-19)
(use file.util)
(use gauche.collection)
(use sxml.serializer)
(use util.cmdargs)
(use util.list)

;;; Customizable section

(define-constant index-html "index.html")

(define-constant index-rdf "index.rdf")

;; list of files not to appear the output
(define skip-files
  `(,index-html
    ,index-rdf
    ".DS_Store"
    ))

;; list of directories not to be dived
(define skip-dirs
  '("_darcs"
    ))

;; SXML skelton
(define (make-sxml-skelton abspath files-sxml)
  `(*TOP*
    (html (@ (xmlns "http://www.w3.org/1999/xhtml")
	     (xml:lang "en"))
	  (head
	   (title "Index of " ,abspath)
	   (link (@ (rel  "stylesheet")
		    (type "text/css")
		    (href ,(stylesheet abspath))))
	   (link (@ (rel  "alternate")
		    (type "application/rss+xml")
		    (href ,(rdf-site-summary abspath))))
	   )
	  (body
	   (div
	    (@ (id "content"))
	    (h1 "Index of "
		(span (@ (class "path")) ,@(path->anchors abspath)))
	    (table
	     (@ (rules "groups")
		(frame "void"))
	     (thead
	      (tr (th "Name")
		  (th "Size")
		  (th "Last modified")))
	     (tbody ,@files-sxml
		    (tr (@ (class "dummy"))
			(td (@ (class "name")))
			(td (@ (class "size")))
			(td (@ (class "mtime"))))))
	    )))))

;; SXML for an each file
(define (file-spec->sxml curdir name label)
  (let ((fullpath (build-path curdir name)))
    `(tr (@ (class ,(file-type name)))
	 (td (@ (class "name"))
	     (a (@ (href ,name)) ,label))
	 (td (@ (class "size"))
	     ,(format-fsize fullpath))
	 (td (@ (class "mtime"))
	     ,(format-mtime fullpath)))))


;; miscellaneous utilities
(define (path-to-root curpath)
  (apply build-path "." (make-list (- (string-count curpath #\/) 1) "..")))

(define (stylesheet curpath)
  (build-path (path-to-root curpath) "_style" "index.css"))

(define (rdf-site-summary curpath)
  (build-path (path-to-root curpath) index-rdf))


(define (file-type path)
  (cond
   ((string=? path "..") "parent")
   ((string-suffix? "/" path) "folder")
   (else "file")))

(define (format-mtime path)
  (let1 t (file-mtime path)
    (if (or (string-suffix? ".." path)
	    (not t))
	"- "
	(date->string (time-utc->date (make-time time-utc 0 t))
		      "~1 ~a ~H:~M ~z"))))

(define (path->anchors path)
  (let ((ps (reverse (string-split path #\/))))
    (intersperse
     "/"
     (reverse
      (cons (car ps)
	    (values-ref (map-accum
			 (lambda (p s)
			   (if (string-null? p)
			       (values p s)
			       (values `(a (@ (href ,(apply build-path s)))
					   ,p)
				       (cons ".." s))))
			 '("..")
			 (cdr ps))
			0))))))

(define-constant kibi 1024.0)
(define-constant units `("\u00A0" "k" "M" "G" "T"))

(define (format-fsize path)
  (define (r n)
    (if (exact? n)
	n
	(/ (ceiling (* n 10.0)) 10)))
  (let loop ((sz (file-size path))
	     (us units))
    (cond ((or (not sz)
	       (zero? sz)
	       (not (file-is-regular? path)))
	   "- ")
	  ((< sz kibi)
	   (format "~A ~AB" (r sz) (car us)))
	  (else
	   (loop (/ sz kibi) (cdr us))))))


;;; entry point
(define (show-usage name oport)
  (display
#`"Usage: ,|name| [OPTIONS] path [abspath]

Generate file index HTML(s) for `path' as if that is `abspath'.
When `abspath' is omittied, it is `/' (root directory).

OPTIONS:
 -f, --force          if output is uptodate, reproduce it
 -n, --dry-run        do not actually generation
 -h, --help           show this message
 -q, --quiet          don't show messages
 -r, --recursive      generate indices downward recursively
 -v, --verbose[=WHEN] display messages on skipping/writing
                      WHEN may be `s' or `w'.
" oport))

(define (main args)
  (receive (argv opt) (parse-cmdargs (cdr args)
		        ((? (f force))
			 (? (n dry-run))
			 (? (q quiet) 'w not >> verbose)
			 (? (r recursive))
			 (: (v verbose) 'w (one-of '(s w #t) !symbol))
			 (? (h help)
			    => (lambda _
				 (show-usage (car args) (current-output-port))
				 (exit 0)))
			 (else _
			   (show-usage (car args) (current-error-port))
			   (exit 1))))
    (let-optionals* argv
	((path ".")
	 (abspath "/"))
      (cond ((null? argv)
	     (show-usage (car args) (current-error-port))
	     (exit 1))
	    (else
	     (write-index-html (sys-realpath path) abspath opt)
	     (exit 0))))))


;;; main routines

(define (make-index path abspath opt)
  (define (filter e)
    (not (or (member e skip-files)
	     )))
  (define (prune? e)
    (or (not (opt'recursive))
	(member e skip-dirs)
	))
  (define (cons2 x y xs ys)
    (values (cons x xs) (cons y ys)))
  (receive (dirs files) (directory-list2 path :children? #t :filter filter)
    (for-each (lambda (dir)
                (write-index-html (build-path path dir)
				  (build-path abspath dir)
				  opt))
              (remove prune? dirs))
    (let*-values (((ds) (map (cut string-append <> "/") dirs))
		  ((fs) (append ds files))
		  ((knil1 knil2) (if (string=? abspath "/")
				     (values '() '())
				     (values '("..") '("Parent Directory"))))
		  ((names labels) (fold2 cons2 knil1 knil2 fs fs)))
      (map file-spec->sxml
	   (circular-list path)
	   (reverse names)
	   (reverse labels)))))

(define (with-preserving-utime path thunk)
  (let ((at (file-atime path))
	(mt (file-mtime path)))
    (unwind-protect
     (thunk)
     (sys-utime path at mt))))

(define (write-sxml port sxml)
  (format port "<?xml version='1.0' encoding='utf-8'?>~%")
  (format port "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">~%")
  (srl:parameterizable
   sxml port
   '(indent . #f)
   '(method . xml)
   '(omit-xml-declaration . #t)))

(define (write-index-html path abspath opt)
  (let ((file-lists (make-index path abspath opt))
	(output-html (build-path path index-html)))
    (cond
     ((and (not (opt'force))
	   (file-exists? output-html)
	   (file-mtime<=? path output-html)
	   (every (cut file-mtime<=? <> output-html)
		  (directory-list path :children? #t :add-path? #t)))
      (when (memq (opt'verbose) '(s #t))
	(format (current-error-port)
		"skipped: ~A~%" (build-path abspath index-html))))
     (else
      (when (memq (opt'verbose) '(w #t))
	(format (current-error-port)
		"wrote: ~A~%" (build-path abspath index-html)))
      (when (not (opt'dry-run))
	(with-preserving-utime path
	  (lambda ()
	    (call-with-output-file output-html
	      (cut write-sxml
		   <> 
		   (make-sxml-skelton abspath file-lists))))))))))

;; Local Variables:
;; mode: gauche
;; end: