226 lines
12 KiB
Common Lisp
226 lines
12 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 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)))))
|