#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do make-boot-set)' -s $0 "$@" # -*- scheme -*-
!#
;;; make-boot-set --- for fun and profit!

;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2009, 2010 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: make-boot-set DIR
;;
;; Write sequence of floppies with the Debian boot set in DIR.
;; A possible money-making scheme, in the right clueless environment.

;;; Code:

(define-module (ttn-do make-boot-set)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv))
  #:use-module ((ice-9 rdelim) #:select (read-line write-line))
  #:use-module ((ttn-do zzz personally) #:select (FE fso))
  #:use-module ((ttn-do zzz filesystem) #:select (dir-exists?))
  #:use-module ((ttn-do zzz subprocess) #:select (shell-command->list
                                                  system*)))

(define concat string-append)

(define (find-filenames dir)
  (let ((cwd (getcwd)))
    (chdir dir)
    (shell-command->list "find . -name '*.bin' -print")))

(define (expect-RET . msgs)
  (apply concat (append msgs (list "\nPress RET to continue."))))

(define (prompt string)
  (write-line string)
  (flush-all-ports)
  (read-line))

(define (dd-fd0 filename)
  (system* "echo dd" (concat "if=" filename) "of=/dev/fd0"))

(define filename->image identity)

(define (write-image image)
  (fso "START Writing image: ~A~%" image)
  (prompt (expect-RET "Place fresh floppy into drive."))
  (let ((write-status (dd-fd0 (filename->image image))))
    (fso "write-status ~A~%" write-status)
    (case write-status
      ((0) (fso "OK Done image: ~A~%" image))
      (else (error "Unhandled write-status:" write-status)))))

(define (make-boot-set dir)
  (prompt (expect-RET "make-boot-set %V"))
  (FE (map filename->image (find-filenames dir)) write-image))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.0")
                   (help . commentary)))
  (or (and (= 2 (length args))
           (let ((dir (cadr args)))
             (and (dir-exists? dir)
                  dir)))
      (let ((me (car args)))
        (execl me me "--help")))
  (make-boot-set (cadr args)))

;;; make-boot-set ends here