git-watch.rkt

#lang racket

(require racket/system
         racket/async-channel)

(provide watch-repo
         make-store)

(define git-command (make-parameter #f))
(define commit-delay (make-parameter #f))
(define status-delay (make-parameter #f))

#;(define (wat command)
  (match-define (list out in pid err control)
    (parameterize ([current-directory "/home/antoine/lol/prj/php-parser"])
      (process (string-append "git" " " command) #:set-pwd? #t)))
  (port->string out))

(define (exec-git-command store command)
  (match-define (list out in pid err control)
    (parameterize ([current-directory (store-repo-path store)])
      (process (string-append (git-command) " " command) #:set-pwd? #t)))
  (control 'wait)
  ;; TODO: what to do in case of error?
  ;; (control 'exit-code)
  (begin0
      (port->string out)
    (close-output-port in)
    (close-input-port out)
    (close-input-port err)))

(define (get-head-commit store)
  (first (string-split (exec-git-command store "rev-parse HEAD") "\n")))

(define (do-commit-check store- channel)
  (define new-last-commit (get-head-commit store-))
  (if (string=? new-last-commit (store-last-commit store-))
      store-
      (let loop ([lines (string-split
                         (exec-git-command store- (string-append "diff --numstat " (store-last-commit store-)))
                         "\n")]
                 [added '()]
                 [deleted '()]
                 [modified '()])
        (if (empty? lines)
            (let ([filtr (lambda (x)
                           (if (store-filter-tracked store-)
                               (filter (lambda (elem) (not (regexp-match? (store-filter-tracked store-) elem))) x)
                               x))])
              (when (not (empty? (filtr added)))
                (async-channel-put channel (cons 'added (filtr added))))
              (when (not (empty? (filtr deleted)))
                (async-channel-put channel (cons 'deleted (filtr deleted))))
              (when (not (empty? (filtr modified)))
                (async-channel-put channel (cons 'modified (filtr modified))))
              (struct-copy store store-
                           [last-commit new-last-commit]))
            (cond
              [(regexp-match? #rx"^0[ \t]+[0-9]+[ \t]+(.+)$" (first lines))
               => (lambda (x) (loop (loop (rest lines)
                                          added
                                          (cons (second x) deleted)
                                          modified)))]
              [(regexp-match? #rx"^[0-9]+[ \t]+0[ \t]+(.+)$" (first lines))
               => (lambda (x) (loop (loop (rest lines)
                                          (cons (second x) added)
                                          deleted
                                          modified)))]
              [(regexp-match? #rx"^[0-9]+[ \t]+[0-9]+[ \t]+(.+)$" (first lines))
               => (lambda (x) (loop (loop (rest lines)
                                          added
                                          deleted
                                          (cons (second x) modified))))])))))

(define (do-status-check store- channel)
  ;; TODO: foldr
  (define (hash-template h elems fun)
    (let loop ([h h]
               [elems elems])
      (if (empty? elems)
          h
          (loop (fun h (first elems)) (rest elems)))))
  (define timestamp (current-seconds))
  (define last-commit (get-head-commit store-))
  (define-values (untracked added modified deleted)
    (parse-status
     (exec-git-command store- "status --porcelain")))
  (define (filtr x)
    (if (store-filter-tracked store-)
        (filter (lambda (elem) (not (regexp-match? (store-filter-tracked store-) elem)))
                x)
        x))

  (define tracked-files0
    (let ([deleted-fl (filter (lambda (elem) (hash-ref (store-tracked-files store-) elem #f)) (filtr deleted))])
      (cond [(empty? deleted-fl) (store-tracked-files store-)]
            [else
             (async-channel-put channel (cons 'deleted deleted-fl))
             (hash-template (store-tracked-files store-) deleted-fl (lambda (h elem) (hash-remove h elem)))])))
  (define tracked-files1
    (let ([modified-fl (filter (lambda (elem)
                                 (let ([tm (hash-ref tracked-files0 elem #f)])
                                   (or (not tm)
                                       (< tm
                                          (file-or-directory-modify-seconds elem)))))
                               (filtr modified))])
      (cond [(empty? modified-fl) tracked-files0]
            [else
             (async-channel-put channel (cons 'modified modified-fl))
             (hash-template tracked-files0 modified-fl (lambda (h elem) (hash-set h elem timestamp)))])))
  (define tracked-files2
    (let ([added-fl (filter (lambda (elem) (not (hash-ref tracked-files1 elem #f)))
                            (filtr added))])
      (cond [(empty? added-fl) tracked-files1]
            [else
             (async-channel-put channel (cons 'added added-fl))
             (hash-template tracked-files1 added-fl (lambda (h elem) (hash-set h elem timestamp)))])))

  (define-values (untracked-added untracked-deleted untracked-modified)
    (untracked-status untracked store- timestamp))
  (when (not (empty? untracked-added))
    (async-channel-put channel (cons 'added untracked-added)))
  (when (not (empty? untracked-deleted))
    (async-channel-put channel (cons 'deleted untracked-deleted)))
  (when (not (empty? untracked-modified))
    (async-channel-put channel (cons 'modified untracked-modified)))
  (struct-copy store store-
               [last-commit last-commit]
               [last-timestamp timestamp]
               [tracked-files tracked-files2]
               [untracked-files
                (let* ([h0 (store-untracked-files store-)]
                       [h1 (hash-template h0 untracked-deleted (lambda (h elem) (hash-remove h elem)))]
                       [h2 (hash-template h1 untracked-modified (lambda (h elem) (hash-set h elem timestamp)))]
                       [h3 (hash-template h2 untracked-added (lambda (h elem) (hash-set h elem timestamp)))])
                  h3)]))

(define (parse-status status)
  (define lines (string-split status "\n"))
  (let loop ([lines lines]
             [untracked '()]
             [added '()]
             [modified '()]
             [deleted '()])
    (if (empty? lines)
        (values untracked added modified deleted)
        (let* ([line (first lines)]
               [modifier (substring line 0 2)]
               [filename (substring (first (string-split line " -> ")) 3)])
          (cond
            [(string=? "??" modifier)
             (loop (rest lines)
                   (cons filename untracked)
                   added modified deleted)]
            [(or (string=? "M " modifier)
                 (char=? #\M (string-ref modifier 1)))
             (loop (rest lines) untracked added
                   (cons filename modified)
                   deleted)]
            [(or (string=? "D " modifier)
                 (char=? #\D (string-ref modifier 1)))
             (loop (rest lines) untracked added modified
                   (cons filename deleted))]
            [(string=? "A " modifier)
             (loop (rest lines) untracked
                   (cons filename added)
                   modified deleted)]
            [else
             (loop (rest lines) untracked added modified deleted)])))))

(define (untracked-status untracked store timestamp)
  (define stored (store-untracked-files store))
  (define set-a (list->set (hash-keys stored)))
  (define set-b (list->set untracked))
  (define (filtr x)
    (if (store-filter-untracked store)
        (filter (lambda (elem) (not (regexp-match? (store-filter-untracked store) elem)))
                x)
        x))
  (values
   ;; added files
   (filtr (set->list (set-subtract set-b set-a)))
   ;; deleted files
   (filtr (set->list (set-subtract set-a set-b)))
   ;; modified
   (for/list ([possible-modified (list->set (set-intersect set-a set-b))]
              #:when (and (< (hash-ref stored possible-modified)
                             (file-or-directory-modify-seconds possible-modified))
                          (or (not (store-filter-untracked store))
                              (not (regexp-match? (store-filter-untracked store) possible-modified)))))
     possible-modified)))

(define (do-all-files-check store- channel)
  (define timestamp (current-seconds))
  (define commit (get-head-commit store-))
  (define (filtr x)
    (if (store-filter-tracked store-)
        (filter (lambda (elem) (not (regexp-match? (store-filter-tracked store-) elem))) x)
        x))
  (define files (filtr (string-split (exec-git-command store- "ls-files") "\n")))
  (when (not (empty? files))
    (async-channel-put channel (cons 'added files)))
  (define-values (untracked _0 _1 _2)
    (parse-status (exec-git-command store- "status --porcelain")))
  ;; We now the untracked from store- is an empty array so every thing is new
  ;; added files.
  (define-values (untracked-added _3 _4)
    (untracked-status untracked store- timestamp))
  (when (not (empty? untracked-added))
    (async-channel-put channel (cons 'added untracked-added)))
  (struct-copy store store-
               [last-commit commit]
               [last-timestamp timestamp]
               [untracked-files (for/hash ([file untracked-added])
                                  (values file timestamp))]))

(struct store [repo-path last-commit last-timestamp untracked-files tracked-files filter-untracked filter-tracked] #:transparent)

(define (make-store repo-path
                    #:last-commit [last-commit #f]
                    #:last-timestamp [last-timestamp #f]
                    #:untracked-files [untracked-files #hash()]
                    #:tracked-files [tracked-files #hash()]
                    #:filter-untracked [filter-untracked #f]
                    #:filter-tracked [filter-tracked #f])
  (store repo-path last-commit last-timestamp untracked-files tracked-files filter-untracked filter-tracked))

(define (watch-repo store- channel
                    #:commit-delay [commit-delay 30.0]
                    #:status-delay [status-delay 2.0]
                    #:git-command [git-command- "git"])
  (thread
   (lambda ()
     (parameterize ([git-command git-command-]
                    [current-directory (store-repo-path store-)])
       (let ([store-
              ;; This repository have never been watched.
              (if (not (store-last-commit store-))
                  (do-all-files-check store- channel)
                  store-)])
         (let loop ([remain-commit-delay commit-delay]
                    [remain-status-delay status-delay]
                    [store- store-])
           (define delay (min remain-commit-delay remain-status-delay))
           (sleep delay)
           ;; First check commit, and status after.
           (define store0
             (if (<= 0 (- remain-commit-delay delay))
                 (do-commit-check store- channel)
                 store-))
           (define store1
             (if (<= 0 (- remain-status-delay delay))
                 (do-status-check store0 channel)
                 store0))
           (loop (max commit-delay (- remain-commit-delay delay))
                 (max status-delay (- remain-status-delay delay))
                 store1)))))))