(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. Use TEST for file extension 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 (string-downcase type) :defaults target))))) (defun get-cue-copy-actions (origin origin-files target &optional (test #'string-equal)) "Return all cue-based copy actions from ORIGIN to TARGET if applicable. ORIGIN-FILES is just a list of all files in ORIGIN. Use TEST for file extension equality." (when-let ((cue-file (find-if (lambda (f) (funcall test (pathname-type f) "cue")) origin-files))) (libcue:with-cue (cd :file cue-file) (let ((track-count (libcue:cd-get-track-count cd))) (when (> track-count (count-if (lambda (f) (funcall test (pathname-type f) "flac")) origin-files)) (loop :with actions := (fset:empty-set) :with track-count-str := (format nil "~2,'0D" track-count) :with cd-rem := (libcue:cd-get-rem cd) :with cd-cd-text := (libcue:cd-get-cd-text cd) :with album-date := (libcue:ensure-nonempty (libcue:get-rem :date cd-rem)) :with album-gain := (libcue:ensure-nonempty (libcue:get-rem :album-gain cd-rem)) :with album-peak := (libcue:ensure-nonempty (libcue:get-rem :album-peak cd-rem)) :with album-title := (libcue:get-cd-text :title cd-cd-text) :with album-artist := (libcue:ensure-nonempty (libcue:get-cd-text :performer cd-cd-text)) :with album-composer := (libcue:ensure-nonempty (libcue:get-cd-text :composer cd-cd-text)) :with album-genre := (libcue:ensure-nonempty (libcue:get-cd-text :genre cd-cd-text)) :for track-number :from 1 :upto track-count :for track-number-str := (format nil "~2,'0D" track-number) :for track := (libcue:cd-get-track cd track-number) :for origin-file-name := (let* ((raw-file (libcue:track-get-file-name track)) (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-rem := (libcue:track-get-rem track) :for track-cd-text := (libcue:track-get-cd-text track) :for track-date := (or (libcue:ensure-nonempty (libcue:get-rem :date track-rem)) album-date) :for track-gain := (libcue:ensure-nonempty (libcue:get-rem :track-gain track-rem)) :for track-peak := (libcue:ensure-nonempty (libcue:get-rem :track-peak track-rem)) :for track-title := (libcue:get-cd-text :title track-cd-text) :for track-artist := (or (libcue:ensure-nonempty (libcue:get-cd-text :performer track-cd-text)) album-artist) :for track-composer := (or (libcue:ensure-nonempty (libcue:get-cd-text :composer track-cd-text)) album-composer) :for track-genre := (or (libcue:ensure-nonempty (libcue:get-cd-text :genre track-cd-text)) album-genre) :for metadata := (let ((metadata)) (flet ((add-metadata (field value) (when value (push (cons field value) metadata)))) (add-metadata "ALBUM" album-title) (add-metadata "TRACKTOTAL" track-count-str) (add-metadata "ALBUMARTIST" album-artist) (add-metadata "TITLE" track-title) (add-metadata "TRACKNUMBER" track-number-str) (add-metadata "ARTIST" track-artist) (add-metadata "COMPOSER" track-composer) (add-metadata "GENRE" track-genre) (add-metadata "DATE" track-date) (add-metadata "REPLAYGAIN_ALBUM_GAIN" album-gain) (add-metadata "REPLAYGAIN_ALBUM_PEAK" album-peak) (add-metadata "REPLAYGAIN_TRACK_GAIN" track-gain) (add-metadata "REPLAYGAIN_TRACK_PEAK" track-peak)) metadata) :for output-file-name := (format nil "~A - ~A" track-number-str (ppcre:regex-replace-all *invalid-char-scanner* 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)) :start (libcue:ensure-nonempty (libcue:track-get-start track)) :length (libcue:ensure-nonempty (libcue:track-get-length track)) :metadata metadata) :unless (some (lambda (p) (equal p origin-file)) origin-files) :return nil :do (fset:adjoinf actions current-action) :finally (return actions))))))) (defun get-image-copy-action (origin-files target &optional (test #'string-equal)) "Determine which image file to copy from ORIGIN-FILES, if any." (when-let ((image-files (remove-if (lambda (f) (let ((f-type (pathname-type f))) (notany (lambda (type) (funcall test f-type type)) *image-extensions*))) origin-files))) (let ((image-file (or (find-if (lambda (f) (let ((f-name (pathname-name f))) (some (lambda (name) (funcall test f-name name)) *album-cover-names*))) image-files) (first image-files)))) (make-copy-action :origin image-file :target (pathname-normalize-unicode (make-pathname :name "cover" :type (let ((type (string-downcase (pathname-type image-file)))) ;; NOTE: Auxio ignores .jpeg (if (equal type "jpeg") "jpg" type)) :defaults target)))))) (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)))) (unless (fset:empty? files) (when-let ((image-action (get-image-copy-action origin-files target))) (fset:adjoinf files image-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)))))