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

(in-package #:sync-music)

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

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)
                 ((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 :directory (pathname-directory target)
                                     :name (pathname-name origin)
                                     :type 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))
      (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)))))