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

#|

  This is a helper to minimize changes to file timestamps by got commands (eg,
  rebasing).  This is done by saving a state table that maps each file in the
  repo and its hash (as given by git) to a timestamp.  The table is later used
  to restore the state -- and for any file with a known hash but a different
  timestamp, we restore the saved timestamp.

  Executive summary: use "gitp" instead of "git", especially when rebasing is
  involved.  For example: "gitp pull --rebase".  If there are conflicts,
  use "gitp" when you're ready to continue after resolving the conflicts, for
  example: "gitp rebase --continue".

  (This could have been more robust by computing a hash for each file, since
  git produces the hash of the file from its store, therefore ignoring any
  changes that are not comitted or staged.  But doing this would be extremely
  slow, and in any case the problem is with files that git knows about.)

  There is a complication in making this work: the git commands in question are
  not running to completion.  For example, doing a rebase will stop when there
  are conflicts to let you resolve them, and continue with `--continue'.
  Therefore, there are two ways to use this script:

  1. Manually save/restore state

     Run "gitp 1" to save the current state, and later run "gitp 2" to restore
     it.  (The "1" "2" were the most convenient things for me to remember...)
     There is also a "gitp 3" which removes the saved state, in case it's
     needed.

  2. Run it as a git replacement: "gitp <git-verb-and-args>".  In this mode,
     the script will save the state before running the git command, and restore
     that state when it's done.  The state is still left in the .git directory,
     so it can be reused later using "gitp 2".

  Note that the script does nothing more than change file timestamps, therefore
  any possible damage it can cause is limited to that.  In other words, the
  contents of your files is safe.

|#

#lang racket/base

(require racket/port racket/path)

(define this
  (string->symbol (path-element->string
                   (file-name-from-path (find-system-path 'run-file)))))

(define (note fmt . args)
  (printf "~a: ~a\n" this (apply format fmt args)))

(define git
  (let ([exe (or (find-executable-path "git")
                 (error this "could not find the git executable"))]
        [stderr    (current-error-port)]
        [from-null (open-input-file "/dev/null")])
    (lambda (reader/outp . args)
      ;; reader/outp can be a function that consumes the subprocess's stdout,
      ;; or a port to dump it onto; in the latter case, it returns the exit
      ;; status rather than exit if it was not 0.
      (define-values [pid pout pin perr]
        (apply subprocess (if (output-port? reader/outp) reader/outp #f)
               from-null stderr exe args))
      (let ([r (if (output-port? reader/outp)
                 (void) (reader/outp pout))])
        (subprocess-wait pid)
        (let ([s (subprocess-status pid)])
          (cond [(output-port? reader/outp) s]
                [(zero? s) r]
                [else (exit s)]))))))

(define (->line  in) (regexp-replace #rx"\n$" (port->string in) ""))
(define (->bline in) (regexp-replace #rx#"\n$" (port->bytes in) ""))
(define (->lines in) (port->lines in))

(define saved-directory (current-directory))
(current-directory (git ->line "rev-parse" "--show-toplevel"))

;; The code refers to `state' and `states'.
;; * The result of `get-current-state' returns the current state of the working
;;   directory tree -- which is a hash table that maps each file name as a byte
;;   string to (list hash date stamp).  The hash+date are the important
;;   information -- the date of the file with the given hash.  The stamp is the
;;   time that this information was captured, to allow garbage-collecting old
;;   entries instead of an ever-growing state.
;; * The information that is actually saved in the metadata file maps each file
;;   name to `states' -- a *list* of such triplets, maping the hash of a file
;;   to a date for every different observed hash.

(define metadata
  (format "~a/.~a-states" (git ->line "rev-parse" "--git-dir") this))

;; Dump the states (could just write the whole table, but it might be useful to
;; look at this).
(define (write-states states)
  (call-with-output-file metadata #:exists 'truncate
    (lambda (o)
      (hash-for-each states (lambda (k v) (fprintf o "~s\n" (cons k v)))))))

;; Read the above.
(define (read-states)
  (define t (make-hash))
  (when (file-exists? metadata)
    (call-with-input-file metadata
      (lambda (in)
        (for ([x (in-producer read eof in)])
          (hash-set! t (car x) (cdr x))))))
  t)

;; git ls files -sz:      mode    sha1       stage    name
(define rx:ls-files #rx#"^[0-9]+ ([0-9a-f]+) [0-9]+\t([^\0]+)$")

;; Gets the current tree state
(define (get-current-state)
  (define t (make-hash))
  (define now (current-seconds))
  (define (update-entry file hash)
    (hash-set! t file
      (list hash (file-or-directory-modify-seconds (bytes->path file)) now)))
  ;; read hashes and names via git
  (git (lambda (in)
         (for ([m (in-producer regexp-match #f #rx#"^([^\0]*)\0" in)])
           (let ([m (cdr (or (regexp-match rx:ls-files (cadr m))
                             (error 'git-ls-files "unexpected line: ~.a"
                                    (car m))))])
             (update-entry (cadr m) (car m)))))
       "ls-files" "-s" "-z")
  ;; for files that were modified, compute their hash and use it instead
  (git (lambda (in)
         (for ([m (in-producer regexp-match #f #rx#"^([^\0]*)\0" in)])
           (update-entry (cadr m) (git ->bline "hash-object" "--"
                                       (bytes->string/utf-8 (cadr m))))))
       "ls-files" "-m" "-z")
  t)

(define (get+update-current-states)
  (define t (read-states))
  (define cur (get-current-state))
  (for ([(file h+d+s) (in-hash cur)])
    (let ([hash (car h+d+s)])
      (hash-set! t file
                 (cons h+d+s (filter (lambda (x) (not (equal? (car x) hash)))
                                     (hash-ref t file '()))))))
  (write-states t)
  t)

(require scheme/nest)
(define (restore-state states)
  (note "restoring state")
  (define changed? #f)
  (define cur (get-current-state))
  (nest ([for ([(file hashes) (in-hash states)])]
         [let ([new (hash-ref cur file #f)])]
         [when new]
         [let ([hash (car new)])]
         [let ([old (assoc hash hashes)])]
         [when old]
         [let ([old-time (cadr old)] [new-time (cadr new)])]
         [unless (equal? old-time new-time)])
    (set! changed? #t)
    (note "  ~a" file)
    (file-or-directory-modify-seconds (bytes->path file) old-time))
  (unless changed? (note "  (nothing to restore)") (flush-output)))

(define (run-protected-command args)
  (note "recording current state")
  (define states (get+update-current-states))
  (define status
    (parameterize ([current-directory saved-directory])
      (apply git (current-output-port) args)))
  (restore-state states)
  (exit status))

(provide main)
(define (main . args)
  (cond [(equal? args '("1"))
         (get+update-current-states)
         (note "saved current state")]
        [(equal? args '("2"))
         (if (file-exists? metadata)
           (restore-state (read-states))
           (error this "missing metadata file to restore state from"))]
        [(equal? args '("3"))
         (if (file-exists? metadata)
           (begin (note "removing saved state") (delete-file metadata))
           (note "no state to remove"))]
        [else (run-protected-command args)]))