#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do write-html-directory-index)' -s $0 "$@" # -*-scheme-*-
!#
;;; write-html-directory-index
;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version. There is NO WARRANTY. See file COPYING for details.
;;; Commentary:
;; Usage: write-html-directory-index [options] [DIR ...]
;;
;; Write index.html in each DIR (or the current directory if none specified),
;; incorporating: a hyperlinked listing of parent directories under docroot;
;; a listing of files in the directory, including size, modification date,
;; "file type" (e.g. "text/plain" or "application/x-tar"), and the filename
;; hyperlinked; and the preformatted content of any README or LEGGIMI files
;; in the directory. Display "wrote: INDEX" for each index file written.
;; The directory listing omits index.html and the README (or LEGGIMI) file.
;;
;; Several options change the bahavior (default values in square braces):
;;
;; -r, --docroot DIR -- Use DIR as the root; the chain of parent dirs
;; stops there [/home/ttn/build/gnuvola]
;; -o, --output FILE -- Write index to FILE [index.html]
;; -x, --exclude FILE -- Also omit FILE from the listing;
;; this option can be given multiple times
;; -l, --label FILE -- Use contents of FILE (if found) instead of
;; README or LEGGIMI (completely replacing them);
;; this option can be given multiple times
;; -q, --quiet -- Don't say "wrote: INDEX"
;;
;; For -o, -x, and -l, signal error if FILE contains a directory component.
;;
;; Caveats:
;; - Not tested w/ symlinked (sub)directories.
;; - The order of specified labels has no bearing on which file is
;; actually chosen, should there be more than one in the directory.
;;; Code:
(define-module (ttn-do write-html-directory-index)
#:export (main directory-index-tree)
#:use-module ((srfi srfi-13) #:select (string-prefix-length
string-take))
#:use-module ((ice-9 regex) #:select (match:prefix))
#:use-module ((ttn-do mogrify) #:select (editing-buffer))
#:use-module ((ttn-do zzz banalities) #:select (check-hv
qop<-args))
#:use-module ((www data mime-types) #:select (reset-mime-types!
put-mime-types-from-file!))
#:use-module ((www utcsec) #:prefix UTCS: #:select (format-utcsec
<-mtime))
#:use-module ((www server-utils filesystem) #:select (filename->content-type))
#:use-module ((ttn-do zzz personally) #:select (accumulator
FE fso))
#:use-module ((ttn-do zzz filesystem) #:select (directory-vicinity
filtered-files-in-vicinity
not-dot-not-dotdot
filename-sans-end-sep-proc
with-cwd))
#:use-module ((ttn-do zzz publishing) #:select (flatten-to))
#:use-module ((ttn-do zzz xhtml-tree) #:select (~simple-strict-xhtml
~head ~title ~body
~h2 ~hr
~pre ~a ~tt
~table ~tr ~td)))
(define *system-mime-types* "/etc/mime.types")
(define (~page/titled title . x)
(~simple-strict-xhtml
(~head (~title title))
(~body x)))
(define RX:suffix:gz (make-regexp "[.]gz$"))
(define (name->type fn)
(cond ((and *system-mime-types* (file-exists? *system-mime-types*))
(reset-mime-types! 491)
(put-mime-types-from-file! 'quail *system-mime-types*)
(set! *system-mime-types* #f)))
(filename->content-type fn "text/plain"))
(define w/o-trailing-slash (filename-sans-end-sep-proc #\/))
;; Return a string-tree representing the directory listing for @var{dir}.
;; @var{ignored} and @var{labels} are lists; @var{upath} and @var{dir} are
;; strings, with or without trailing a slash. Normally, @var{upath} is part
;; of @var{dir}, e.g.:
;;
;; @example
;; UPATH: /software/ttn-do/
;; DIR: /home/ttn/build/gnuvola/software/ttn-do/
;; @end example
;;
(define (directory-index-tree ignored labels upath dir)
(set! upath (w/o-trailing-slash upath))
(~page/titled
(list "Directory " (if (string-null? upath) "/" upath))
(let ((acc (accumulator)))
(let loop ((start 0))
(cond ((string-index upath #\/ start)
=> (lambda (cut)
(set! cut (1+ cut))
(acc (cons start cut))
(loop cut)))
((null? (acc))
'())
(else
(list
(~h2 "Parent Directories")
(~table
(map (lambda (x)
(~tr (~td "")
(~td (~a 'href (string-take upath (cdr x))
(substring upath (car x) (cdr x))))))
(acc)))
(~hr))))))
(~h2 "Directory " (if (string-null? upath) "/" (basename upath)))
(let* ((label #f)
(? vector-ref)
(under-dir (directory-vicinity dir))
(subd "(subdir)"))
(define (suitable fn)
(and (not-dot-not-dotdot fn)
(not (member fn ignored))
(cond ((and (not label) (member fn labels))
(set! label fn)
#f)
(else #t))
(let* ((si (stat (under-dir fn)))
(mt (UTCS:format-utcsec #f "%F %T"
(UTCS:<-mtime si))))
(if (eq? 'directory (stat:type si))
(vector subd
""
(string-append fn "/")
mt)
(vector (cond ((regexp-exec RX:suffix:gz fn)
=> (lambda (m)
(name->type (match:prefix m))))
(else
(name->type fn)))
(number->string (stat:size si))
fn mt)))))
(define (dirs-first a b)
(cond ((let ((a-dir? (eq? subd (? a 0)))
(b-dir? (eq? subd (? b 0))))
(or (and a-dir?
b-dir?)
(and (not a-dir?)
(not b-dir?))))
(string<? (? a 2) (? b 2)))
(else
(eq? subd (? a 0)))))
(list
(let ((all (sort (filtered-files-in-vicinity dir suitable) dirs-first)))
(~table 'width "85%"
(map (lambda (type size fn mtime)
;; 0 1 2 3
(~tr (~td "")
(~td 'align "right" (~tt size))
(~td 'align "center" (~tt mtime))
(~td type)
(~td (~a 'href fn (~tt fn)))))
(map (lambda (x) (? x 0)) all)
(map (lambda (x) (? x 1)) all)
(map (lambda (x) (? x 2)) all)
(map (lambda (x) (? x 3)) all))))
(if label
(editing-buffer #t
(define (gsr was now)
(goto-char (point-min))
(while (search-forward was #f #t)
(replace-match now #t #t)))
(insert-file-contents (under-dir label))
(gsr "&" "&")
(gsr ">" ">")
(gsr "<" "<")
(list
(~hr)
(~pre (buffer-string))))
'())))))
(define (main/qop qop)
(let* ((docroot (or (qop 'docroot w/o-trailing-slash) "/home/ttn/build/gnuvola"))
(dlength (string-length docroot))
(dirs (if (null? (qop '())) (list ".") (qop '())))
(absolutes (map (lambda (dir)
(with-cwd dir (getcwd)))
dirs))
(upaths (map (lambda (abs)
(if (= dlength (string-prefix-length docroot abs))
(substring abs dlength)
(error "Not under docroot:" abs)))
absolutes))
(index-name (or (qop 'output) "index.html"))
(ignored (cons index-name (or (qop 'exclude) '())))
(labels (or (qop 'label) '("README" "LEGGIMI"))))
(FE dirs absolutes upaths
(lambda (dir abs upath)
(call-with-output-file (in-vicinity abs index-name)
(lambda (port)
(flatten-to port (directory-index-tree
ignored labels upath abs))))
(or (qop 'quiet)
(fso "wrote: ~A~%" (in-vicinity dir index-name)))))))
(define (main args)
(check-hv args '((package . "ttn-do")
(version . "1.9")
(help . commentary)))
(main/qop
(qop<-args
args (let* ((base-only (lambda (filename)
(string=? filename (basename filename))))
(base-only-opts `((value #t) (predicate ,base-only))))
`((docroot (single-char #\r) (value #t))
(output (single-char #\o) ,@base-only-opts)
(exclude (single-char #\x) (merge-multiple? #t) ,@base-only-opts)
(label (single-char #\l) (merge-multiple? #t) ,@base-only-opts)
(quiet (single-char #\q)))))))
;;; write-html-directory-index ends here