#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do snap-iso)' -s $0 "$@" # -*-scheme-*-
!#
;;; snap-iso

;; Copyright (C) 2004, 2005, 2006, 2007, 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: snap-iso [OPTIONS] SPECFILE [SELECTION]
;;
;; Create an ISO9660 image file, using SELECTION from SPECFILE.  If not
;; specified, SELECTION is taken to be "default".  Run two sizing passes,
;; one with du(1) and one with genisoimage(1), before the actual creation.
;; Options are:
;;
;;  -o, --output FILE   -- write FILE (by default the filename has the
;;                         form BASE.SEL.iso, where BASE is the basename
;;                         of SPECFILE, and SEL is the selection name)
;;  -w, --warning-exit  -- cause genisoimage sizing pass warnings to result
;;                         in failureful exit (by default they are ignored)
;;  -m, --missing FILE  -- write "no such file" filenames signalled by the
;;                         du sizing pass to FILE
;;  -T, --tmpdir DIR    -- use DIR for staging and output
;;  -n, --noact         -- exit after sizing passes, leaving directory
;;                         BASE.SEL.snap-iso (see ‘-o’ for explanation)
;;  -q, --quiet         -- say (almost) nothing
;;
;; SPECFILE names a file containing "selections" that define directories
;; and files to be included/excluded in the ISO image.  Directory- and
;; file-names are written as Scheme symbols.  A selection has the form:
;;
;;   (NAME COMPONENT ...)
;;
;; NAME is a keyword, such as "#:default".  COMPONENT may be another
;; selection name (keyword), a relative directory- or file-name, or a
;; vector of the form:
;;
;;   #(PARENT #:except CHILD ...)
;;
;; PARENT is a directory name.  CHILD names a subdirectory or file in the
;; PARENT directory; it cannot contain the slash (directory separator)
;; character.  The keyword #:except is required syntax.
;;
;; The special name #:OMIT must be followed by absolute filenames.  These
;; are ignored by the genisoimage sizing pass and the ISO-creation command,
;; but not by the du sizing pass.

;;; Code:

(define-module (ttn-do snap-iso)
  #:export (main)
  #:use-module ((srfi srfi-13) #:select (string-prefix?
                                         string-take
                                         string-drop-right))
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
  #:use-module ((ttn-do mogrify) #:select (editing-buffer))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE fs make-fso))
  #:use-module ((ttn-do zzz subprocess) #:select (sysfmt))
  #:use-module ((ttn-do zzz filesystem) #:select (directory-vicinity
                                                  mkdir-p
                                                  filtered-files
                                                  not-dot-not-dotdot
                                                  filename-absolute-or-in-vicinity))
  #:use-module ((ttn-do zzz subprocess) #:select (make-buffered-caller)))

(define *err* (current-error-port))

(define (spew format-string . args)
  (apply format *err* (string-append "snap-iso: " format-string "~%") args))

(define (huh? . args) #f)

(define (chdir-verbosely dir)
  (spew "changing directory to ~A" dir)
  (chdir dir))

(define (rmdir-r-verbosely dir)
  (spew "recursively deleting dir ~A" dir)
  (sysfmt "rm -rf ~A" dir))

(define (delete-file-verbosely filename)
  (spew "deleting file ~A" filename)
  (delete-file filename))

(define (mkdir-p-verbosely dir)
  (spew "making directory ~A" dir)
  (mkdir-p dir))

(define (symlink-verbosely source target)
  (let ((target-parent (dirname target)))
    (or (file-exists? target-parent)
        (mkdir-p-verbosely target-parent)))
  (spew "making symlink ~A -> ~A" target source)
  (symlink source target))

(define absvic (directory-vicinity "/"))

(define (do-symlinks ls<-kw init)
  (define (plan p x) (set-object-property! x #:plan p) x)
  (define (doplan x) ((object-property x #:plan) x))
  (define (really x) (mkdir-p-verbosely x))
  (define (fakely x) (symlink-verbosely (absvic x) x))
  (define (expand spec)
    (cond ((pair? spec)
           (apply append (map expand spec)))
          ((keyword? spec)
           (let ((v (ls<-kw spec)))
             (spew "expanding ~A => ~A" spec v)
             (expand v)))
          ((and (vector? spec)
                (< 2 (vector-length spec))
                (eq? #:except (vector-ref spec 1)))
           (let* ((parent (symbol->string (vector-ref spec 0)))
                  (under-parent (directory-vicinity parent))
                  (except (map symbol->string (cddr (vector->list spec))))
                  (filter (lambda (file)
                            (and (not-dot-not-dotdot file)
                                 (not (member file except))
                                 (plan fakely (under-parent file))))))
             (FE except (lambda (ex)
                          (and (string-index ex #\/)
                               (error "bad except spec:" ex))))
             (cons (plan really parent)
                   (filtered-files filter (absvic parent)))))
          (else
           (list (plan fakely (cond ((string? spec) spec)
                                    ((symbol? spec) (symbol->string spec))
                                    (else (error "bad spec:" spec))))))))
  ;; do it!
  (FE (expand init) doplan))

(define (sub-1 s)
  (string-drop-right s 1))

(define (main/qop qop)
  (and (qop 'quiet) (set! spew huh?))
  (let ((tmpdir (or (getenv "TMPDIR") (qop 'tmpdir) "/tmp"))
        (args (qop '())))
    (and (null? args) (error "no SPECFILE specified"))
    (let* ((specfile (car args))
           (specs (forms<-file specfile))
           (sel (if (= 1 (length args))
                    #:default
                    (symbol->keyword (string->symbol (cadr args)))))
           (xo (cond ((assq-ref specs #:OMIT)
                      => (lambda (ls)
                           (map (lambda (name)
                                  (set! name (symbol->string name))
                                  (and (or (string-null? name)
                                           (< (string-length name) 2)
                                           (not (char=? #\/ (string-ref name 0))))
                                       (error "bad #:OMIT name:" name))
                                  (substring name 1))
                                ls)))
                     (else '()))))
      (or (null? xo) (set! specs (assq-remove! specs #:OMIT)))
      (let ((chk (assq-ref specs sel)))
        ((if chk spew error)
         (if chk "using ~A from ~A" "could not find ~A in ~A")
         sel specfile))
      (or (string=? tmpdir (getcwd))
          (chdir-verbosely tmpdir))
      (let* ((frag (fs "~A.~A" (basename specfile) (keyword->symbol sel)))
             (symroot (fs "~A.snap-iso" frag))
             (outfile (or (qop 'output) (fs "~A.iso" frag))))
        (and (file-exists? symroot)
             ((if (file-is-directory? symroot)
                  rmdir-r-verbosely
                  delete-file-verbosely)
              symroot))
        (mkdir-p-verbosely symroot)
        (chdir-verbosely symroot)
        (do-symlinks (lambda (kw) (assq-ref specs kw)) sel)
        (let* ((du (make-buffered-caller "du -sLb ."))
               (s (and (du #:execute) (du #:outbuf-string)))
               (size (string->number (string-take s (string-index s #\ht)))))
          (cond ((zero? (du #:exit-val))
                 (spew "total size according to du: ~A bytes" size))
                (else
                 (spew "partial size according to du: ~A bytes" size)
                 (spew "du errors encountered while determining size:~%~A"
                       (sub-1 (du #:errbuf-string)))
                 (let ((nxo (accumulator)))
                   (editing-buffer (du #:errbuf)
                     (goto-char (point-min))
                     (while (re-search-forward "‘(..*)’: No such"
                                               (point-max) #t)
                       (let ((problem (match-string 1)))
                         (and (< 2 (string-length problem))
                              (string-prefix? "./" problem)
                              (nxo (substring problem 2))))))
                   (spew "additional files to be omitted: ~A" (length (nxo)))
                   (set! xo (append xo (nxo))))
                 (cond ((qop 'missing
                             (lambda (name)
                               (filename-absolute-or-in-vicinity
                                 name (in-vicinity tmpdir symroot))))
                        => (lambda (m-name)
                             (spew "writing omitted filenames in ~A"
                                   m-name)
                             (call-with-output-file m-name
                               (lambda (m)
                                 (let ((fm (make-fso m)))
                                   (FE xo (lambda (name)
                                            (fm "~A~%" name))))))))))))
        (chdir-verbosely tmpdir)
        (let* ((std-args `("genisoimage -R -D" "-f" ,symroot
                           ,@(map (lambda (name)
                                    (fs "-x ~A/~A" symroot name))
                                  xo)))
               (get-size `(,@std-args "-print-size -quiet" ,symroot))
               (make-iso `(,@std-args "-o" ,outfile ,symroot))
               (gen-iso (make-buffered-caller (car get-size)
                                              #:args (cdr get-size)))
               (blocks (and (gen-iso #:execute)
                            (zero? (gen-iso #:exit-val))
                            (sub-1 (gen-iso #:outbuf-string)))))
          (let ((es (gen-iso #:errbuf-string))
                (when "encountered while determining size")
                (bail (lambda ()
                        (spew "sorry, bailing out! -- NOTE: dir remains: ~A/~A"
                              tmpdir symroot)
                        (exit #f))))
            (cond ((not blocks)
                   (spew "genisoimage errors ~A:~%~A" when (sub-1 es))
                   (bail))
                  ((not (string-null? es))
                   (spew "genisoimage warnings ~A:~%~A" when (sub-1 es))
                   (and (qop 'warning-exit) (bail)))))
          (spew "size according to genisoimage: ~A blocks" blocks)
          (cond ((qop 'noact)
                 (spew "exiting -- NOTE: dir remains: ~A/~A" tmpdir symroot)
                 (exit #t)))
          (apply gen-iso #:redefine make-iso)
          (spew "making ~A ~A" outfile (cons "command:" make-iso))
          (spew "(please wait)")
          (gen-iso #:execute)
          (let* ((ev (gen-iso #:exit-val))
                 (ok? (zero? ev)))
            (spew "~A (genisoimage exit value: ~A)"
                  (if ok? "everything ok" "badness!")
                  ev)
            (and (file-exists? outfile)
                 (spew "~A size: ~A bytes" outfile (stat:size (stat outfile))))
            (rmdir-r-verbosely symroot)
            (spew "exiting")
            (exit ok?)))))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.2")
                   (help . commentary)))
  (main/qop
   (qop<-args
    args '((output (single-char #\o) (value #t))
           (warning-exit (single-char #\w))
           (missing (single-char #\m) (value #t))
           (tmpdir (single-char #\T))
           (quiet (single-char #\q))
           (noact (single-char #\n))))))

;;; snap-iso ends here