;;; extracted from  itunes.scm
(use objc plist)

(define-objc-classes NSMutableDictionary)

(define (itunes:open-library name)
  (or (@ NSMutableDictionary
         dictionary-with-contents-of-file:
         (expand-tilde name))
      (error 'itunes:open-library "failed to open library" name)))

(define (expand-tilde name)
  (@ (if (ns:string? name) name (ns:make-string name))
     string-by-expanding-tilde-in-path))

(define (itunes:write-library plist dest-name)
  (@ plist write-to-file: (expand-tilde dest-name) atomically: #t))

(define (itunes:tracks plist)
  (let ((tracks (@ plist object-for-key: "Tracks")))
    (unless
      (@ tracks is-kind-of-class: NSDictionary)
      (error 'itunes:tracks "tracks key is not a dictionary."))
    tracks))

(define-objc-classes NSURL)

(define (ns:string->URL str) (@ NSURL URL-with-string: str))

(define (write-list x file) (with-output-to-file file (lambda () (pp x))))

(use srfi-13)

(define (string-index-right-n str c n)
  (let ((start 0))
    (let loop ((end (string-length str)) (n n))
      (if (zero? n)
        end
        (and end (loop (string-index-right str c start end) (fx- n 1)))))))

(define (pathname-components-right path n)
  (let ((index (string-index-right-n path pathname-directory-separator n)))
    (if index (substring path index) path)))

(use posix)

(define (music-table-ref table key)
  (let ((path (hash-table-ref/default table key #f)))
    (cond ((not (pair? path)) path)
          ((null? (cdr path)) (car path))
          (else (make-duplicate path)))))

(define (make-duplicate filenames) (cons 'duplicate path))

(define (duplicate? file) (and (pair? file) (eq? 'duplicate (car file))))

(define (bad-file? x) (eq? (car x) 'bad-file))

(define (bad-file-name x) (cadr x))

(define (bad-file-URL x) (caddr x))

(define (make-moved-item bad-file dest) (list 'moved bad-file dest))

(define (moved-item? x) (eq? (car x) 'moved))

(define (moved-item-source x) (cadr x))

(define (moved-item-destination x) (caddr x))

(define (make-bad-file-list x) (cons 'bad-file-list x))

(define (bad-file-list? x) (eq? (car x) 'bad-file-list))

(define (bad-file-list-items x) (cdr x))

(use srfi-1)

(define (bad-file-list-filter pred x)
  (make-bad-file-list (filter pred (bad-file-list-items x))))

(define (moved-item-duplicate? x) (duplicate? (moved-item-destination x)))

(define (moved-item-notfound? x) (not (moved-item-destination x)))

(define (moved-item-unique? x) (string? (moved-item-destination x)))

(define (make-URL->moved-item-table bad-file-list)
  (let ((h (make-hash-table string=?)))
    (for-each
      (lambda (m) (hash-table-set! h (bad-file-URL (moved-item-source m)) m))
      (bad-file-list-items bad-file-list))
    h))

(define (path->URL x) (@ (@ NSURL file-URL-with-path: x) absolute-string))

(define (create-directories pathname . traverse-symlinks?)
  (let ((make-pathname
          (if (absolute-pathname? pathname)
            make-absolute-pathname
            make-pathname)))
    (let loop ((path-done '())
               (path-left
                 (string-split
                   pathname
                   (string pathname-directory-separator))))
      (if (null? path-left)
        pathname
        (let ((next-path (append path-done (list (car path-left))))
              (pathname-so-far (make-pathname path-done (car path-left))))
          (if (directory? pathname-so-far)
            (loop next-path (cdr path-left))
            (if (file-exists? pathname-so-far)
              (if (and (symbolic-link? pathname-so-far)
                       (:optional traverse-symlinks? #t)
                       (directory? (make-pathname pathname-so-far #f)))
                (loop next-path (cdr path-left))
                (error 'create-directories "file exists" pathname-so-far))
              (begin
                (create-directory pathname-so-far)
                (loop next-path (cdr path-left))))))))))

(define (result-type x) (car x))

(define (result-items x) (cdr x))

(define (make-result type items) (cons type items))

(define (result? x) (symbol? (result-type x)))

(define (filter-result pred x)
  (if (result? x)
    (make-result (result-type x) (filter pred (result-items x)))
    (error 'filter-result "not a result list")))

(define (moved-item-error? x) (error? (moved-item-destination x)))

(define (error? x) (and (pair? x) (eq? (car x) 'error)))

(define (make-link-error msg dest) (list 'error msg dest))

(define (error->boolean thunk) (handle-exceptions _ #f (begin (thunk) #t)))

(define (create-symbolic-link* old new)
  (error->boolean (lambda () (create-symbolic-link old new))))

(define (error->string exn)
  (let ((msg ((condition-property-accessor 'exn 'message #f) exn))
        (loc ((condition-property-accessor 'exn 'location #f) exn))
        (args ((condition-property-accessor 'exn 'arguments #f) exn)))
    (cond ((null? args) msg)
          ((and (pair? args) (null? (cdr args))) (conc msg ": " (car args)))
          (else (conc msg ": " args)))))

(define-macro
  (try try-block catch-proc)
  (let ((exn (gensym)))
    `(handle-exceptions ,exn (,catch-proc ,exn) ,try-block)))

(define itunes:music-regexp (make-parameter ".*.([Mm][Pp]3|[Aa][Aa][Cc])"))

(define (find-music-files base-dir sig)
  (let ((table (make-hash-table string=?)))
    (for-each
      (lambda (fn)
        (let ((short-name (pathname-components-right fn sig)))
          (hash-table-set!
            table
            short-name
            (let ((old-key (hash-table-ref/default table short-name #f)))
              (if old-key (cons fn old-key) (list fn))))))
      (find-files
        base-dir
        (itunes:music-regexp)
        cons
        '()
        (lambda (fn) (not (symbolic-link? fn)))))
    table))

(define (make-music-lookup base-dir . significant-path-components)
  (let* ((sig-components (:optional significant-path-components 3))
         (table (find-music-files base-dir sig-components)))
    (lambda (path)
      (music-table-ref
        table
        (pathname-components-right path sig-components)))))

(define (make-moved-lookup bad-files)
  (let ((table (make-URL->moved-item-table bad-files)))
    (lambda (location) (hash-table-ref/default table location #f))))

(define (location-fold tracks meat)
  (ns:enumerator-fold
    (lambda (x xs)
      (let* ((location (@ x object-for-key: "Location"))
             (URL (ns:string->URL location)))
        (if URL
          (if (@ URL is-file-URL)
            (meat x xs location (ns:string-value (@ URL path)))
            xs)
          (begin (warning "invalid URL: " location) xs))))
    '()
    (@ tracks object-enumerator)))

(define (get-bad-files tracks music-lookup)
  (make-result
    'bad-file-list
    (location-fold
      tracks
      (lambda (x xs location name)
        (if (file-exists? name)
          xs
          (cons `(moved (bad-file ,name ,(ns:string-value location))
                        ,(music-lookup name))
                xs))))))

(define (link-files tracks moved-lookup)
  (make-result
    'link-results
    (location-fold
      tracks
      (lambda (x xs location name)
        (let ((moved-item (moved-lookup (ns:string-value location))))
          (if moved-item
            (if (string=? name (bad-file-name (moved-item-source moved-item)))
              (if (moved-item-unique? moved-item)
                (let ((src (bad-file-name (moved-item-source moved-item)))
                      (dst (moved-item-destination moved-item)))
                  (try (begin
                         (create-directories (pathname-directory src))
                         (create-symbolic-link dst src)
                         (cons moved-item xs))
                       (lambda (exn)
                         (cons (make-moved-item
                                 (moved-item-source moved-item)
                                 (make-link-error (error->string exn) dst))
                               xs))))
                xs)
              xs)
            xs))))))

(define (move-files tracks moved-lookup)
  (make-result
    'move-results
    (location-fold
      tracks
      (lambda (x xs location name)
        (let ((moved-item (moved-lookup (ns:string-value location))))
          (if moved-item
            (if (string=? name (bad-file-name (moved-item-source moved-item)))
              (if (moved-item-unique? moved-item)
                (begin
                  (@ x
                     set-object:
                     (path->URL (moved-item-destination moved-item))
                     for-key:
                     "Location")
                  (cons moved-item xs))
                xs)
              xs)
            xs))))))