#lang racket/base

;; This module provides a cross-platform, polling based file watch.

  racket/contract

  racket/list

  racket/set)

  (contract-out

    [robust-poll-milliseconds (parameter/c exact-positive-integer?)]

    [robust-watch  (->* () (path-on-disk? #:batch? any/c) thread?)]))

;; ------------------------------------------------------------------ 

;; Implementation

  racket/hash

  "./filesystem.rkt"

  "./threads.rkt")

(define-values (report-activity report-status) (report-iface 'robust))

(define robust-poll-milliseconds (make-parameter 250))

(define (get-file-attributes path)

  (with-handlers ([exn:fail? (λ _ #f)])

    (list (file-or-directory-modify-seconds path)

          (file-or-directory-permissions path 'bits)

          (cond

            [(file-exists? path)      (file-size path)] ; does path resolve to a file?

            [(directory-exists? path) 0]                ; does path resolve to a directory?

            [else                     0]))))

(define (get-listing-numbers listing)

  (for/list ([p listing])

    (define attrs (get-file-attributes p))

    (if (not attrs)

        -1

        (apply + attrs))))

(define (get-robust-state path)

    (define listing (if (file-exists? path)

                        (list path)

                        (recursive-file-list path)))

    (make-immutable-hash (map cons

                              listing

                              (get-listing-numbers listing))))

(define (mark-changes prev next)

  (hash-union prev next

              #:combine/key (lambda (k a b)

                              (if (= a b) 'same 'change))))

(define (mark-status prev next)

  (make-immutable-hash

    (map

      (lambda (pair)

        (if (symbol? (cdr pair))

          pair

          (cons (car pair)

                (if (path-on-disk? (car pair)) 'add 'remove))))

    (hash->list (mark-changes prev next)))))

(define (get-next-status current-state complete-path)

  (define next (get-robust-state complete-path))

  (define status-marked-hash (mark-status current-state next))

  (values next status-marked-hash))

(define (robust-watch [path (current-directory)] #:batch? [batch? #f])

  (define complete-path (path->complete-path (simplify-path path #t)))

  (thread

   (lambda ()

     (let loop ([state (get-robust-state complete-path)])

       (define exists? (path-on-disk? complete-path))

       (define next

         (cond [(not exists?)

                (report-activity 'remove complete-path)

                #f]

               [(equal? #f batch?)

                ; file exists, we should NOT batch notifications

                (define-values (next status-marked-hash)

                  (get-next-status state complete-path))

                (hash-for-each

                 status-marked-hash

                 (lambda (affected op)

                   (unless (equal? op 'same)

                     (report-activity op affected))))

                next]

               [else

                ; file exists, we SHOULD batch notifications

                (define-values (next status-marked-hash)

                  (get-next-status state complete-path))

                (define report (filter-not (lambda (arg) (equal? 'same (cdr arg)))

                                           (hash->list status-marked-hash)))

                (when (not (null? report))

                  (define messages

                    (for/list ([item report])

                      ;item looks like, e.g.:   (cons <path:/foo/bar> 'add)

                      (list 'robust (cdr item) (car item))))

                  (report-change-literal messages))

                next]))

       ; if we reported a 'remove on the original state then next is #f and we can stop

       ; watching.

       (when next

         (sync/enable-break (alarm-evt (+ (current-inexact-milliseconds)

                                          (robust-poll-milliseconds))))

         (loop next))))))

(module+ test

  (require

    rackunit

    racket/async-channel

    racket/file

    (submod "./filesystem.rkt" test-lib)

    (submod "./threads.rkt" test-lib))

  (define (allow-poll) (sleep (/ (robust-poll-milliseconds) 1000)))

  (test-case

     "Robust watch over directory, unbatched"

    (parameterize ([current-directory (create-temp-directory)]

                   [robust-poll-milliseconds 50]

                   [file-activity-channel (make-async-channel)])

      (create-file "a")

      (create-file "b")

      (create-file "c")

      (define th (robust-watch))

      (allow-poll)

      (delete-file "c") (create-file "c")

      (delete-file "b")

      (allow-poll)

      (delete-directory/files (current-directory))

      (thread-wait th)

      ; TODO: Paratition these messages into "may appear" and "must appear"

      (define expected-messages

        `((robust change ,(build-path (current-directory) "c")) ; must

          (robust remove ,(build-path (current-directory) "b")) ; may

          (robust remove ,(build-path (current-directory)))))   ; must

      (let loop ()

        (define msg (file-watcher-channel-try-get))

        (when msg

          (check-true (and (member msg expected-messages) #t))

          (loop)))))

  (test-case

     "Robust watch over directory, batched"

    (parameterize ([current-directory (create-temp-directory)]

                   [robust-poll-milliseconds 50]

                   [file-activity-channel (make-async-channel)])

      (define dir2  (create-temp-directory))

      (parameterize ([current-directory dir2])

        (make-directory* (build-path "foo" "bar" "baz"))

        (current-directory (build-path "foo" "bar" "baz"))

        (create-file "a.txt"))

      (define th (robust-watch #:batch? #t))

      (allow-poll)

      (rename-file-or-directory (build-path dir2 "foo")

                                (build-path (current-directory) "foo"))

      (delete-directory/files dir2)

      (allow-poll)

      (allow-poll)

      (define messages (file-watcher-channel-try-get))

      (allow-poll)

      (define dir (current-directory))

      (check-equal? (sort messages path<? #:key last)

                    `((robust add ,(build-path dir "foo"))

                      (robust add ,(build-path dir "foo/bar"))

                      (robust add ,(build-path dir "foo/bar/baz"))

                      (robust add ,(build-path dir "foo/bar/baz/a.txt"))))

      (delete-directory/files (current-directory))

      (thread-wait th)))

  (test-case

     "Robust watch over file"

    (parameterize ([current-directory (create-temp-directory)]

                   [robust-poll-milliseconds 50]

                   [file-activity-channel (make-async-channel)])

      (create-file (build-path "a"))

      (define th (robust-watch "a"))

      (allow-poll)

      (delete-file "a")

      (allow-poll)

      (thread-wait th)

      (delete-directory/files (current-directory))

      (check-equal?

        (sync (file-activity-channel))

        `(robust remove ,(build-path (current-directory) "a"))))))