#!/usr/bin/guile \
--debug -e %main -s
!#

;; utils

(use-modules ((srfi srfi-19)
              #:renamer (symbol-prefix-proc 'srfi-19:))
             ((srfi srfi-1)
              #:select (fold))
             ((srfi srfi-13)
              #:select (string-join)))

(define (ensure-fdes port mode)
  (or (false-if-exception (fileno port))
      (open-fdes *null-device* mode)))

(define (move-fdes from to)
  (cond ((not (= from to))
         (dup2 from to)
         (close-fdes from))))

(define (port-eos? port)
  (and (char-ready? port)
       (eof-object? (peek-char port))))

(define (chars-to-port fromport toport)
  (if (and (char-ready? fromport)
           (not (port-eos? fromport)))
      (begin
        (write-char (read-char fromport) toport)
        (chars-to-port fromport toport))))

(define (%spawnlp filename . args)
  (let ((outpipe (pipe))
        (errpipe (pipe)))
    (let ((pid (primitive-fork)))
      (if (= pid 0)
          (let ((in-fdes (ensure-fdes (current-input-port) O_RDONLY))
                (out-fdes (fileno (cdr outpipe)))
                (err-fdes (fileno (cdr errpipe))))

            (port-for-each (lambda (pt-entry)
                             (false-if-exception
                              (let ((pt-fileno (fileno pt-entry)))
                                (if (not (or (= pt-fileno in-fdes)
                                             (= pt-fileno out-fdes)
                                             (= pt-fileno err-fdes)))
                                    (close-fdes pt-fileno))))))

            (move-fdes in-fdes 0)
            (move-fdes out-fdes 1)
            (move-fdes err-fdes 2)
            (apply execlp filename filename args))
          (let* ((ports (list (cons (car outpipe) (current-output-port))
                              (cons (car errpipe) (current-error-port))))
                 (select (lambda ()
                           (select (map car ports) '() (map car ports)))))
            
            (for-each close-port (map cdr (list outpipe errpipe)))
            (let lp ((sret (select)))
              (for-each
               (lambda (port)
                 (cond ((assq-ref ports port)
                        => (lambda (to) (chars-to-port port to)))
                       (else
                        (throw 'cant-happen))))
               (car sret))
              (cond ((and (null? (caddr sret))
                          (not (fold (lambda (x knil)
                                       (and knil (port-eos? x)))
                                     #t (car sret))))
                     (lp (select)))
                    (else
                     (let ((waitval (waitpid pid)))
                       (for-each close-port (map car ports))
                       waitval)))))))))

(define (spawnlp filename . args)
  (let ((exit-val (status:exit-val
                   (cdr (apply %spawnlp filename args)))))
    (eq? exit-val 0)))

(define (null-output-port)
  (open-output-file *null-device*))

(define (with-output-to-null proc)
  (with-output-to-port (null-output-port) proc))

(define (with-error-to-null proc)
  (with-error-to-port (null-output-port) proc))

(define (with-output-to-error proc)
  (with-output-to-port (current-error-port) proc))

(define (with-output-and-error-to-port port proc)
  (with-output-to-port port (lambda () (with-error-to-port port proc))))

(define (with-output-and-error-to-null proc)
  (with-output-and-error-to-port (null-output-port) proc))

(define (string->date str)
  (let ((str* (with-output-to-string
                (lambda () (spawnlp "date" "-d" str "+%F %T")))))
    (srfi-19:string->date str* "~Y~m~d~H~M~S")))

(define (date->string date)
  (srfi-19:date->string date "~Y-~m-~d ~H:~M:~S"))

(define (make-command-line . args)
  (string-join (map (lambda (x) (string-append "\"" x "\"")) args) " "))

(define (debug . args)
  (for-each display args)
  (newline))

(define (date-difference d1 d2)
  (srfi-19:time-difference (srfi-19:date->time-monotonic d1)
                           (srfi-19:date->time-monotonic d2)))
  
(define (date-add-seconds d seconds)
  (srfi-19:time-utc->date
   (srfi-19:add-duration
    (srfi-19:date->time-utc d) 
    (srfi-19:make-time srfi-19:time-duration 0 seconds))))

(define (date<=? d1 d2)
  (srfi-19:time<=? (srfi-19:date->time-monotonic d1)
                   (srfi-19:date->time-monotonic d2)))
  
(define (date-difference-sufficiently-small? stop start)
  (srfi-19:time<=? (date-difference stop start)
                   (srfi-19:make-time srfi-19:time-duration 0 3600)))

(define (date-mean start stop)
  (let ((diff (date-difference stop start)))
    (date-add-seconds
     start (inexact->exact (floor (/ (srfi-19:time-second diff) 2))))))

;; code

(define (cvs . args)
  (or (apply spawnlp "cvs" args)
      (throw 'cvs-error args)))

(define (with-nonfatal-cvs-errors proc)
  (catch 'cvs-error proc (lambda args #f)))

(define (set-cvs-date! date)
  (debug "* Updating tree to " (date->string date) "...")
  (with-output-and-error-to-null
   (lambda ()
     (cvs "update" "-d" "-P" "-D" (date->string date)))))

(define (in-cvs-tree?)
  (with-output-and-error-to-null 
   (lambda ()
     (with-nonfatal-cvs-errors
      (lambda () (cvs "status"))))))

(define (assert-in-cvs-tree!)
  (debug "* Making sure we're in a CVS tree...")
  (if (not (in-cvs-tree?))
      (with-output-to-error
       (lambda ()
         (display "Error: ")
         (display (car (program-arguments)))
         (display " needs to be run from within a CVS checkout.\n")
         (exit 1)))))

(define (run-check command args)
  (debug "* Running check")
  (let ((ret (apply spawnlp command args)))
    (debug "* Check " (if ret "passed" "failed"))
    ret))

(define (run-check-for-date date command args)
  (set-cvs-date! date)
  (run-check command args))

(define (assert-check-run-on-date! date command args expected)
  (debug "* Checking that the check " (if expected "succeeds" "fails")
         " on " (date->string date) "...")
  (let* ((port (open-output-string))
         (res (with-output-and-error-to-port
               (or port (current-output-port))
               (lambda () (run-check-for-date date command args)))))
    (cond ((not (eq? res expected))
           (debug "* Expected a " (if expected "passing" "failing")
                  " result on " (date->string date) ",")
           (debug "  but command unexpectedly "
                  (if expected "failed" "passed") ".")
           (debug)
           (debug "Command: " (apply make-command-line command args))
           (debug)
           (debug "Failed output:")
           (debug)
           (debug (get-output-string port))
           (exit 1)))))
 
(define (run-bisection start-date stop-date command args)
  (cond
   ((date-difference-sufficiently-small? stop-date start-date)
    (debug "* Bisection stopped.")
    (debug)
    (debug "Command:")
    (debug "  " (apply make-command-line command args))
    (debug "started to fail somewhere between " (date->string start-date)
           " and " (date->string stop-date) ".")
    (exit 0))
   (else
    (let ((mean (date-mean start-date stop-date)))
      (if (run-check-for-date mean command args)
          (run-bisection mean stop-date command args)
          (run-bisection start-date mean command args))))))

(define (main start-date-str stop-date-str command . args)
  (let ((start-date (string->date start-date-str))
        (stop-date (string->date stop-date-str)))
    (catch 'cvs-error
           (lambda ()
             (assert-in-cvs-tree!)
             (assert-check-run-on-date! start-date command args #t)
             (assert-check-run-on-date! stop-date command args #f)
             (run-bisection start-date stop-date command args))
           (lambda (key args)
             (format (current-error-port)
                     "Error runnng ~A with arguments ~S, exiting.\n"
                     "cvs" args)
             (exit 1)))))

;; invocation

(define (usage)
  (format #t "usage: ~a START-DATE STOP-DATE COMMAND ARGS...\n"
          (car (command-line))))

(define (%main args)
  (if (not (>= (length args) 4))
      (begin
        (with-output-to-error usage)
        (exit 1)))
  (apply main (cdr args)))