#!/bin/sh
#| -*- scheme -*-
exec mzscheme "$0" "$@"
|#

#lang scheme/base

(require scheme/cmdline scheme/system)

(define mode        #f)
(define archive     #f)
(define input-files '())
(define cmd         #f)

(command-line
  #:once-any
  [("-p") archive-file "pack mode"
   (set! mode 'pack)
   (set! archive archive-file)]
  [("-u") archive-file "unpack mode"
   (set! mode 'unpack)
   (set! archive archive-file)]
  [("-c") command archive-file ("command to execute on a created archive,"
                                "to be unpacked and removed when done")
   (set! mode 'command)
   (set! archive archive-file)
   (set! cmd command)]
  #:args file
  (set! input-files file))

(define (err fmt . args) (apply error 'multifile fmt args))

(define pack?   (memq mode '(pack command)))
(define unpack? (eq? mode 'unpack))

(unless (and mode archive)
  (err "must specify pack or unpack mode and archive name"))

(when (and unpack? (pair? input-files))
  (err "cannot specify files in unpack mode"))
(when (and pack? (null? input-files))
  (err "must specify files to pack"))

(let ([bad (filter (lambda (f) (not (file-exists? f))) input-files)])
  (unless (null? bad)
    (let ([dirs (filter directory-exists? input-files)])
      (if (null? dirs)
        (err "input file/s not found: ~s" bad)
        (err "got directory arguments: ~s" dirs)))))

(define (ask prompt)
  (printf "~a " prompt) (flush-output)
  (regexp-match? #rx"^ *[yY]" (read-line)))

(let ([exists? (file-exists? archive)])
  (cond [unpack? (unless exists? (err "archive file missing"))]
        [(and exists? (not (ask "archive file exists, delete?")))
         (err "archive file exists")]
        [exists? (delete-file archive)]))

(define (read-file file)
  (with-input-from-file file (lambda () (read-bytes (file-size file)))))

;; ========== pack

(define (show-header)
  (printf "Files in this archive:\n")
  (for ([f input-files]) (printf "  ~a\n" f)))

(define (show-file file)
  (define buf (read-file file))
  (define-values (open-delimiter close-delimiter)
    (let loop ([rnd #""] [n 10])
      (let ([open  (bytes-append #"{<{<{" rnd)]
            [close (bytes-append #"}>}>}" rnd)])
        (if (or (regexp-match? (regexp-quote open)  buf)
                (regexp-match? (regexp-quote close) buf))
          (loop (string->bytes/utf-8 (number->string (random n)))
                (min 1000000000 (* n 10)))
          (values open close)))))
  (printf "\n\f\n===>>> ~s\n~a\n" file open-delimiter)
  (display buf)
  (printf "\n~a\n" close-delimiter))

(define footer
  '(""
    ""
    ";; Local v\141riables:"
    ";; hide-local-variable-section: t"
    ";; eval:(add-color-pattern \"^===>>>.*\\n\" 'yellow/red4-bold 0 t)"
    ";; End:"))

(define (pack)
  (let ([stdout (current-output-port)])
    (with-output-to-file archive
      (lambda ()
        (show-header)
        (for ([file input-files])
          (fprintf stdout "packing ~s...\n" file)
          (show-file file))
        (for ([line footer]) (printf "~a\n" line))))))

;; ========== unpack

(define open-rx #rx#"\n===>>> (\"[^\n]*\")\n{<{<{([0-9]*)\n")
(define close-rx-fmt "\n}>}>}~a\n")

(define (unpack)
  (with-input-from-file archive
    (lambda ()
      (let loop ()
        (let ([m (regexp-match open-rx (current-input-port))])
          (when m
            (let* ([file (parameterize ([current-input-port
                                         (open-input-bytes (cadr m))])
                           (read))]
                   [delim (format close-rx-fmt (caddr m))]
                   [delim (string->bytes/utf-8 delim)]
                   [delim (regexp-quote delim)]
                   [delim (byte-regexp (bytes-append #"^(.*?)" delim))]
                   [buf (cadr (or (regexp-match delim (current-input-port))
                                  (err "end delimiter not found ~s" delim)))]
                   [same? (and (file-exists? file)
                               (= (bytes-length buf) (file-size file))
                               (equal? buf (read-file file)))])
              (unless same?
                (printf "extracting ~s...\n" file)
                (with-output-to-file file #:exists 'truncate
                  (lambda () (display buf) (flush-output))))
              (loop)))))))
  (delete-file archive))

;; ========== command

(define (command)
  (let ([cmd (format "~a \"~a\"" cmd archive)])
    (pack)
    (printf "running ~a...\n" cmd)
    (unless (or (system cmd)
                (ask "got an error exit code, continue unpacking?"))
      (err "aborting..."))
    (unpack)))

;; ========== run

(case mode [(pack) (pack)] [(unpack) (unpack)] [(command) (command)]
      [else (err "internal error")])