lisp-scripts/sync-music/sync-music.lisp

(in-package #:sync-music)

(defun make-file-copy-action (origin target &optional (test #'string-equal))
  "Create subclass of COPY-ACTION based on the filetype of ORIGIN and TEST for equality.

Return the action if it exists, or NIL if the file should not be copied."
  (when-let* ((type (pathname-type origin))
              (make-action-fn
               (cond
                 ((funcall test type "flac")
                  (setf type "opus")
                  #'make-copy-flac-action)
                 ((and *dumb-cue-copy-p*
                       (member type *meta-extensions* :test test))
                  #'make-copy-meta-action)
                 ((member type *general-extensions* :test test)
                  #'make-copy-action))))
    (funcall make-action-fn
             :origin origin
             :target (pathname-normalize-unicode
                      (make-pathname :name (pathname-name origin)
                                     :type type
                                     :defaults target)))))

(defun get-cue-copy-actions (origin origin-files target &optional (test #'string-equal))
  (when-let* ((cue-file (uiop:native-namestring
                         (find-if (lambda (f)
                                    (funcall test (pathname-type f) "cue"))
                                  origin-files)))
              (cue-track-count (parse-integer
                                (uiop:run-program (list "cueprint"
                                                        "-d" "%N"
                                                        cue-file)
                                                  :output :string
                                                  :ignore-error-status t)
                                :junk-allowed t)))
    (when (> cue-track-count (count-if (lambda (f)
                                         (funcall test (pathname-type f) "flac"))
                                       origin-files))
      (loop :repeat cue-track-count
            :with actions := (fset:empty-set)
            :with album-data-raw := (uiop:run-program
                                     (list "cueprint"
                                           "-d" "%T\\n%02N\\n%P"
                                           cue-file)
                                     :output :lines)
            :with track-data-raw := (uiop:run-program
                                     (list "cueprint"
                                           "-t" "%f\\n%t\\n%02n\\n%p\\n%c\\n%g\\n"
                                           cue-file)
                                     :output :lines)
            :with break-start-data-raw := (uiop:run-program
                                           (list "cuebreakpoints"
                                                 "--append-gaps"
                                                 cue-file)
                                           :output :lines)
            :with break-end-data-raw := (uiop:run-program
                                         (list "cuebreakpoints"
                                               "--prepend-gaps"
                                               cue-file)
                                         :output :lines)
            ;; HACK: Determine if track 1 has pregap based on breakpoint count
            :with track-1-pregap-p := (< (length break-start-data-raw)
                                         (length break-end-data-raw))
            :for origin-file-name := (let* ((raw-file (pop track-data-raw))
                                            (dot (position #\. raw-file :from-end t)))
                                       (subseq raw-file 0 dot))
            :for origin-file := (make-pathname :name origin-file-name
                                               :type "flac"
                                               :defaults origin)
            :for track-title := (first track-data-raw)
            :for track-number := (second track-data-raw)
            :for data-raw := (append album-data-raw
                                     (loop :repeat 5
                                           :collect (pop track-data-raw)))
            :for metadata := (mapcar #'cons
                                     '("ALBUM"
                                       "TRACKTOTAL"
                                       "ALBUMARTIST"
                                       "TITLE"
                                       "TRACKNUMBER"
                                       "ARTIST"
                                       "COMPOSER"
                                       "GENRE")
                                     data-raw)
            :for metadata-filtered := (delete-if (compose #'emptyp #'cdr) metadata)
            :for previous-action := nil :then current-action
            :for output-file-name := (ppcre:regex-replace-all *invalid-char-scanner*
                                                              (format nil
                                                                      "~A - ~A"
                                                                      track-number
                                                                      track-title)
                                                              "!!!")
            :for current-action := (make-copy-flac-action
                                    :origin origin-file
                                    :target (pathname-normalize-unicode
                                             (make-pathname :name output-file-name
                                                            :type "opus"
                                                            :defaults target))
                                    :metadata metadata-filtered)
            :do (fset:adjoinf actions current-action)
            :with previous-file
            :do (cond
                  ((equal previous-file origin-file-name)
                   (setf (copy-flac-action-start current-action) (pop break-start-data-raw))
                   (setf (copy-flac-action-end previous-action) (pop break-end-data-raw)))
                  (t
                   (unless (uiop:file-exists-p origin-file)
                     (return))
                   (when track-1-pregap-p
                     (setf (copy-flac-action-start current-action) (pop break-end-data-raw)))
                   (setf previous-file origin-file-name)))
            :finally (return actions)))))

(defun get-all-copy-actions (origin target &optional (depth 0))
  "Recursively iterate ORIGIN for files to copy.

Return a set of all copy actions as first value, and set of all directory
actions that need performing in order to store the targets as second value."
  (check-depth (incf depth))
  (let ((files (fset:empty-set))
        (directories (fset:empty-set)))
    (unless (and *ignore-toplevel-p* (= depth 1))
      (let ((origin-files (uiop:directory-files origin)))
        (if-let ((cue-copy-actions (and (not *dumb-cue-copy-p*)
                                        (get-cue-copy-actions origin origin-files target))))
          (fset:unionf files cue-copy-actions)
          (dolist (file (uiop:directory-files origin))
            (when-let ((action (make-file-copy-action file target)))
              (fset:adjoinf files action))))))
    (dolist (directory (uiop:subdirectories origin))
      (let ((target-directory
              (make-pathname :directory (append (pathname-directory target)
                                                (list (p-utils:directory-name directory))))))
        (multiple-value-bind (subdir-files subdir-directories)
            (get-all-copy-actions directory target-directory depth)
          (fset:unionf files subdir-files)
          (fset:unionf directories subdir-directories))))
    (when (and (fset:empty? directories) (fset:nonempty? files))
      (fset:adjoinf directories
                    (make-directory-action :target (pathname-normalize-unicode target))))
    (values files directories)))

(defun get-all-delete-actions (target &optional (depth 0))
  "Recursively iterate TARGET for files to delete.

Return a set of all preexisting files as first value, and set of all
directories to not create as the second value."
  (check-depth (incf depth))
  (let ((files (fset:empty-set))
        (directories (fset:set (make-directory-action :target target))))
    (unless (and *ignore-toplevel-p* (= depth 1))
      (dolist (file (uiop:directory-files target))
        (fset:adjoinf files (make-delete-action :target file))))
    (dolist (directory (uiop:subdirectories target))
      (multiple-value-bind (subdir-files subdir-directories)
          (get-all-delete-actions directory depth)
        (fset:unionf files subdir-files)
        (fset:unionf directories subdir-directories)))
    (values files directories)))

(defun get-all-actions (origin target)
  "Consolidate all copy and delete actions from ORIGIN to TARGET.

Return a set of all copy actions as first value, all delete actions as second
value, and all directories that should be created as the third value."
  (let ((*max-depth* *max-depth*))
    (mvlet ((all-copy all-directory (get-all-copy-actions origin target))
            (all-delete all-directory-existing (get-all-delete-actions target)))
      (values
       (fset:set-difference all-copy all-delete)
       (if *cleanupp* (fset:set-difference all-delete all-copy) (fset:empty-set))
       (fset:set-difference all-directory all-directory-existing)))))

(defun perform-actions (actions &optional progress-handler)
  "Perform all ACTIONS in a parallelized manner.

Main thread calls PROGRESS-HANDLER (if given) with the progress queue and the
total task count as arguments."
  (let ((task-count (fset:size actions))
        (channel (lparallel:make-channel))
        (queue (when progress-handler (lparallel.queue:make-queue))))
    (fset:do-set (action actions)
      (lparallel:submit-task channel #'action-perform action queue))
    (when progress-handler
      (funcall progress-handler queue task-count))
    (loop :repeat task-count
          :do (lparallel:receive-result channel))))

(defun clean-directory (target)
  "Delete all empty folders and folders containing only empty folders in TARGET."
  ;; NOTE: Want (every #'clean-directory ...) but without short-circuiting
  (and (every #'identity
              (mapcar #'clean-directory (uiop:subdirectories target)))
       (null (uiop:directory-files target))
       (uiop:delete-empty-directory target)))

(defun sync-music (origin target &key confirmp progress-handler)
  "Get and perform all actions from ORIGIN to TARGET.

Calls CONFIRMP with all the actions and only continues if it returns non-NIL.
Passes PROGRESS-HANDLER to PERFORM-ACTIONS."
  (let ((target-directory (uiop:resolve-location
                           (ensure-directories-exist
                            (uiop:merge-pathnames*
                             (uiop:ensure-directory-pathname target)))))
        (origin-directory (uiop:directory-exists-p origin)))
    (unless origin-directory
      (error "Music directory `~A` does not exist!" origin))
    (when (or (p-utils:subpath-p target-directory origin-directory)
              (p-utils:subpath-p origin-directory target-directory))
      (error "Cannot sync if target or origin are a direct subpath of the other."))
    (multiple-value-bind (copy-actions delete-actions directory-actions)
        (get-all-actions origin-directory target-directory)
      (and confirmp
           (not (funcall confirmp copy-actions delete-actions directory-actions))
           (return-from sync-music))
      (fset:do-set (action directory-actions)
        (action-perform action))
      (lparallel.kernel-util:with-temp-kernel ((or *worker-threads*
                                                   (max (- (count-cpus) 2) 1)))
        (perform-actions (fset:unionf copy-actions delete-actions)
                         progress-handler))
      (when *cleanupp*
        (clean-directory target-directory)))))