#lang scheme/base

(provide delete-directory/files
         copy-directory/files
         make-directory*
         make-temporary-file

         get-preference
         put-preferences

         fold-files
         find-files
         pathlist-closure)

;; utility: sorted dirlist so functions are deterministic
(define (sorted-dirlist [dir (current-directory)])
  (let* ([ps (directory-list dir)]
         [ps (map (lambda (p) (cons (path->string p) p)) ps)]
         [ps (sort ps (lambda (p1 p2) (string<? (car p1) (car p2))))]
         [ps (map cdr ps)])
    ps))

(define (delete-directory/files path)
  (unless (path-string? path)
    (raise-type-error 'delete-directory/files "path or string" path))
  (cond
   [(or (link-exists? path) (file-exists? path))
    (delete-file path)]
   [(directory-exists? path)
    (for-each (lambda (e) (delete-directory/files (build-path path e)))
              (sorted-dirlist path))
    (delete-directory path)]
   [else (error 'delete-directory/files
                "encountered ~a, neither a file nor a directory"
                path)]))

(define (copy-directory/files src dest)
  (cond [(file-exists? src)
         (copy-file src dest)]
        [(directory-exists? src)
         (make-directory dest)
         (for-each (lambda (e)
                     (copy-directory/files (build-path src e)
                                           (build-path dest e)))
                   (sorted-dirlist src))]
        [else (error 'copy-directory/files
                     "encountered ~a, neither a file nor a directory"
                     src)]))

(define (make-directory* dir)
  (let-values ([(base name dir?) (split-path dir)])
    (when (and (path? base)
               (not (directory-exists? base)))
      (make-directory* base))
    (unless (directory-exists? dir)
      (make-directory dir))))

(define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f])
  (with-handlers ([exn:fail:contract?
                   (lambda (x)
                     (raise-type-error 'make-temporary-file
                                       "format string for 1 argument"
                                       template))])
    (format template void))
  (unless (or (not copy-from)
              (path-string? copy-from)
              (eq? copy-from 'directory))
    (raise-type-error 'make-temporary-file
                      "path, valid-path string, 'directory, or #f"
                      copy-from))
  (unless (or (not base-dir) (path-string? base-dir))
    (raise-type-error 'make-temporary-file
                      "path, valid-path, string, or #f"
                      base-dir))
  (let ([tmpdir (find-system-path 'temp-dir)])
    (let loop ([s (current-seconds)][ms (current-milliseconds)])
      (let ([name (let ([n (format template (format "~a~a" s ms))])
                    (cond [base-dir (build-path base-dir n)]
                          [(relative-path? n) (build-path tmpdir n)]
                          [else n]))])
        (with-handlers ([exn:fail:filesystem:exists?
                         (lambda (x)
                           ;; try again with a new name
                           (loop (- s (random 10))
                                 (+ ms (random 10))))])
          (if copy-from
              (if (eq? copy-from 'directory)
                  (make-directory name)
                  (copy-file copy-from name))
              (close-output-port (open-output-file name)))
          name)))))

(define (with-pref-params thunk)
  (parameterize ([read-case-sensitive #f]
                 [read-square-bracket-as-paren #t]
                 [read-curly-brace-as-paren #t]
                 [read-accept-box #t]
                 [read-accept-compiled #f]
                 [read-accept-bar-quote #t]
                 [read-accept-graph #t]
                 [read-decimal-as-inexact #t]
                 [read-accept-dot #t]
                 [read-accept-infix-dot #t]
                 [read-accept-quasiquote #t]
                 [read-accept-reader #f]
                 [print-struct #f]
                 [print-graph #f] ; <--- FIXME: temporary solution to DrScheme-pref problem
                 [print-box #t]
                 [print-vector-length #t]
                 [current-readtable #f])
    (thunk)))

(define pref-cache (make-weak-box #f))

(define (path->key p)
  (string->symbol (bytes->string/latin-1 (path->bytes p))))

(define (pref-cache-install! fn-key fn-date f)
  (let ([table (or (weak-box-value pref-cache)
                   (make-hash-table))])
    (hash-table-put! table 
                     (path->key fn-key)
                     (cons
                      (file-or-directory-modify-seconds fn-date #f (lambda () -inf.0))
                      f))
    (unless (eq? table (weak-box-value pref-cache))
      (set! pref-cache (make-weak-box table)))))

(define (get-prefs flush-mode filename)
  (define (read-prefs default-pref-file)
    (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
      (let* ([pref-file
              (or filename
                  (let ([f default-pref-file])
                    (if (file-exists? f)
                        ;; Using `file-exists?' means there's technically a
                        ;; race condition, but something has gone really wrong
                        ;; if the file disappears.
                        f
                        ;; Error here bails out through above `with-handlers'
                        (build-path (collection-path "defaults")
                                    "plt-prefs.ss"))))]
             [prefs (with-pref-params
                     (lambda ()
                       (with-input-from-file pref-file read)))])
        ;; Make sure file content had the right shape:
        (if (and (list? prefs)
                 (andmap (lambda (x)
                           (and (pair? x) (pair? (cdr x)) (null? (cddr x))))
                         prefs))
            prefs
            null))))
  (let* ([fn (path->complete-path
              (or filename
                  (find-system-path 'pref-file)))]
         [cache (let ([table (weak-box-value pref-cache)])
                  (and table (hash-table-get table (path->key fn) #f)))])
    (if (and cache
             (or (not flush-mode)
                 (and (eq? flush-mode 'timestamp)
                      (= (car cache)
                         (file-or-directory-modify-seconds fn #f (lambda () -inf.0))))))
        (cdr cache)
        (let ([ts (file-or-directory-modify-seconds fn  #f (lambda () -inf.0))]
              [f (read-prefs fn)])
          (pref-cache-install! fn fn f)
          f))))

(define (get-preference name [fail-thunk (lambda () #f)]
                        [refresh-cache? 'timestamp]
                        [filename #f])
  (unless (symbol? name)
    (raise-type-error 'get-preference "symbol" name))
  (unless (and (procedure? fail-thunk)
               (procedure-arity-includes? fail-thunk 0))
    (raise-type-error 'get-preference "procedure (arity 0)" fail-thunk))
  (let ([f (get-prefs refresh-cache? filename)])
    (let ([m (assq name f)])
      (if m (cadr m) (fail-thunk)))))

(define (put-preferences names vals [lock-there #f] [filename #f])
  (unless (and (list? names) (andmap symbol? names))
    (raise-type-error 'put-preferences "list of symbols" names))
  (unless (list? vals)
    (raise-type-error 'put-preferences "list" vals))
  (unless (= (length names) (length vals))
    (raise-mismatch-error
     'put-preferences
     (format "the size of the name list (~a) does not match the size of the value list (~a): "
             (length names) (length vals))
     vals))
  (let-values ([(pref-file lock-file pref-dir)
                (let ([filename (or filename (find-system-path 'pref-file))])
                  (let-values ([(base name dir?) (split-path filename)])
                    (let ([dir (if (symbol? base)
                                   (current-directory)
                                   base)])
                      (unless (directory-exists? dir)
                        (make-directory* dir))
                      (values
                       filename
                       (build-path dir
                                   (bytes->path-element
                                    (bytes-append
                                     (if (eq? 'windows (system-type))
                                         #"_"
                                         #".")
                                     #"LOCK"
                                     (path-element->bytes name))))
                       dir))))])
    (with-handlers ([exn:fail:filesystem:exists?
                     (lambda (x)
                       (if lock-there
                           (lock-there lock-file)
                           (error 'put-preferences
                                  "some other process has the preference-file lock, as indicated by the existence of the lock file: ~e"
                                  lock-file)))])
      ;; Grab lock:
      (close-output-port (open-output-file lock-file #:exists 'error))
      (dynamic-wind
          void
          (lambda ()
            (let ([f (get-prefs #t filename)])
              (set! f (let loop ([f f][a null])
                        (cond
                         [(null? f) (reverse
                                     (append (map list names vals)
                                             a))]
                         [else (if (memq (caar f) names)
                                   (loop (cdr f) a)
                                   (loop (cdr f) (cons (car f) a)))])))
              ;; To write the file, copy the old one to a temporary name
              ;; (preserves permissions, etc), write to the temp file,
              ;; then move (atomicly) the temp file to the normal name.
              (let ([tmp-file (make-temporary-file
                               "TMPPREF~a"
                               (and (file-exists? pref-file) pref-file)
                               pref-dir)])
                ;; If something goes wrong, try to delete the temp file.
                (with-handlers ([exn:fail? (lambda (exn)
                                             (with-handlers ([exn:fail:filesystem? void])
                                               (delete-file tmp-file))
                                             (raise exn))])
                  ;; Write to temp file...
                  (with-output-to-file tmp-file
                    #:exists 'truncate/replace
                    (lambda ()
                      (with-pref-params
                       (lambda ()
                         ;; If a pref value turns out to be unreadable, raise
                         ;;  an exception instead of creating a bad pref file.
                         (parameterize ([print-unreadable #f])
                           ;; Poor man's pretty-print: one line per entry.
                           (printf "(\n")
                           (for-each (lambda (a)
                                       (if (and (list? (cadr a))
                                                (< 4 (length (cadr a))))
                                           (begin
                                             (printf " (~s\n  (\n" (car a))
                                             (for-each (lambda (i) (printf "   ~s\n" i)) (cadr a))
                                             (printf "  ))\n"))
                                           (printf " ~s\n" a)))
                                     f)
                           (printf ")\n"))))))
                  ;; Install the new table in the cache. It's possible that this
                  ;; cache entry will be replaced by a reading thread before we
                  ;; move the file, but that's ok. It just means that a future
                  ;; reading thread will have to read again.
                  (pref-cache-install! (path->complete-path
                                        (or filename
                                            (find-system-path 'pref-file)))
                                       tmp-file
                                       f)
                  (rename-file-or-directory tmp-file pref-file #t)))))
          (lambda ()
            ;; Release lock:
            (delete-file lock-file))))))

;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
(define (fold-files f init [path #f] [follow-links? #t])
  (define (do-path path acc)
    (cond [(and (not follow-links?) (link-exists? path)) (f path 'link acc)]
          [(directory-exists? path)
           (call-with-values (lambda () (f path 'dir acc))
             (letrec ([descend
                       (case-lambda
                        [(acc)
                         (do-paths (map (lambda (p) (build-path path p))
                                        (sorted-dirlist path))
                                   acc)]
                        [(acc descend?)
                         (if descend? (descend acc) acc)])])
               descend))]
          [(file-exists? path) (f path 'file acc)]
          [(link-exists? path) (f path 'link acc)] ; dangling links
          [else (error 'fold-files "path disappeared: ~e" path)]))
  (define (do-paths paths acc)
    (cond [(null? paths) acc]
          [else (do-paths (cdr paths) (do-path (car paths) acc))]))
  (if path (do-path path init) (do-paths (sorted-dirlist) init)))

(define (find-files f [path #f])
  (reverse
   (fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc))
               null path)))

(define (pathlist-closure paths)
  (let loop ([paths (map (lambda (p) 
                           (let ([p2 (if (link-exists? p)
                                         (let ([p2 (resolve-path p)])
                                           (if (relative-path? p2)
                                               (let-values ([(base name dir?) (split-path p)])
                                                 (build-path base p2))
                                               p2))
                                         p)])
                             (simplify-path p2 #f)))
                         paths)]
             [r '()])
    (if (null? paths)
        (reverse r)
        (let loop2 ([path (car paths)]
                    [new (cond [(file-exists? (car paths))
                                (list (car paths))]
                               [(directory-exists? (car paths))
                                (find-files void (car paths))]
                               [else (error 'pathlist-closure
                                            "file/directory not found: ~a"
                                            (car paths))])])
          (let-values ([(base name dir?) (split-path path)])
            (if (path? base)
                (loop2 base (if (or (member base r) (member base paths))
                                new (cons base new)))
                (loop (cdr paths) (append (reverse new) r))))))))