254 lines
14 KiB
Common Lisp
254 lines
14 KiB
Common 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.
|
|
|
|
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-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-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))
|
|
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)))))
|