feat!: sync-music: properly utilize cuesheets

Instead of blindly copying over .cue files, attempt to parse them with
cuetools and use the data to split up the associated flac files.  Old behavior
is available under --dumb-cue-copy.

nix/sync-music.nix

@@ -2,7 +2,8 @@
   sbcl,
   lib,
   writeText,
-  ffmpeg,
+  cuetools,
+  ffmpeg-headless,
   makeWrapper,
 }: let
   sync-music = sbcl.buildASDFSystem rec {
@@ -13,6 +14,7 @@
     lispLibs = with sbcl.pkgs; [
       alexandria
       babel
+      cl-ppcre
       fset
       lparallel
       pathname-utils
@@ -26,7 +28,8 @@
     ];
 
     runtimeInputs = [
-      ffmpeg
+      cuetools
+      ffmpeg-headless
     ];
 
     buildScript = writeText "build-sync-music.lisp" ''

sync-music.asd

@@ -6,6 +6,7 @@
                (:file "sync-music" :depends-on ("package" "utils")))
   :depends-on (#:alexandria
                #:babel
+               #:cl-ppcre
                #:fset
                #:lparallel
                #:pathname-utils

sync-music/actions.lisp

@@ -4,7 +4,10 @@
   (target nil :type pathname))
 (defstruct (copy-action (:include action))
   (origin nil :type pathname))
-(defstruct (copy-flac-action (:include copy-action)))
+(defstruct (copy-flac-action (:include copy-action))
+  (start nil :type (or string null))
+  (end nil :type (or string null))
+  (metadata nil :type (soft-alist-of string string)))
 (defstruct (copy-meta-action (:include copy-action)))
 (defstruct (delete-action (:include action)))
 (defstruct (directory-action (:include action)))
@@ -31,14 +34,22 @@ Pushes status message about this action to QUEUE if given."))
 
 (defmethod action-perform ((a copy-flac-action) &optional queue)
   (declare (ignore queue))
-  (uiop:run-program (list "ffmpeg" "-n"
+  (uiop:run-program
-                          "-filter_threads" "1"
+   `("ffmpeg" "-n"
-                          "-i" (uiop:native-namestring (copy-action-origin a))
+              "-filter_threads" "1"
-                          "-c:a" "libopus"
+              "-i" ,(uiop:native-namestring (copy-action-origin a))
-                          "-map" "0:a"
+              ,@(when-let ((start (copy-flac-action-start a)))
-                          "-ac" "2"
+                  `("-ss" ,(convert-timestamp start)))
-                          "-b:a" *opus-bitrate*
+              ,@(when-let ((end (copy-flac-action-end a)))
-                          (uiop:native-namestring (action-target a)))))
+                  `("-to" ,(convert-timestamp end)))
+              ,@(loop :for (tag . value) :in (copy-flac-action-metadata a)
+                      :collect "-metadata"
+                      :collect (format nil "~A=~A" tag value))
+              "-c:a" "libopus"
+              "-map" "0:a"
+              "-ac" "2"
+              "-b:a" ,*opus-bitrate*
+              ,(uiop:native-namestring (action-target a)))))
 
 (defmethod action-perform ((a copy-meta-action) &optional queue)
   (declare (ignore queue))

sync-music/main.lisp

@@ -29,6 +29,10 @@
    :long "depth"
    :arg-parser #'parse-integer
    :meta-var "MAX-DEPTH")
+  (:name :dumb-cue-copy-p
+   :description "blindly copy cue files instead of parsing them"
+   :short #\c
+   :long "dumb-cue-copy")
   (:name :dry-run-p
    :description "print out actions and exit"
    :short #\n
@@ -85,6 +89,7 @@
                                 *opus-bitrate*))
             (*max-depth* (or (getf options :max-depth)
                              *max-depth*))
+            (*dumb-cue-copy-p* (getf options :dumb-cue-copy-p))
             (*dry-run-p* (getf options :dry-run-p))
             (*cleanupp* (not (getf options :no-cleanup-p)))
             (*ignore-toplevel-p* (not (getf options :no-ignore-toplevel-p))))

sync-music/package.lisp

@@ -6,6 +6,7 @@
            #:*max-depth*
            #:*cleanupp*
            #:*ignore-toplevel-p*
+           #:*dumb-cue-copy-p*
            #:*general-extensions*
            #:*meta-extensions*
            #:*action-perform-output*

sync-music/sync-music.lisp

@@ -1,23 +1,114 @@
 (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.
+  "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)
+                 ((funcall test type "flac")
-                 ((member type *meta-extensions* :test test) #'make-copy-meta-action)
+                  (setf type "opus")
-                 ((member type *general-extensions* :test test) #'make-copy-action))))
+                  #'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 :directory (pathname-directory target)
+                      (make-pathname :name (pathname-name origin)
-                                     :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)
+                                :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 := (substitute #\! #\/ (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.
 
@@ -27,9 +118,13 @@ actions that need performing in order to store the targets as second value."
   (let ((files (fset:empty-set))
         (directories (fset:empty-set)))
     (unless (and *ignore-toplevel-p* (= depth 1))
-      (dolist (file (uiop:directory-files origin))
+      (let ((origin-files (uiop:directory-files origin)))
-        (when-let ((action (make-file-copy-action file target)))
+        (if-let ((cue-copy-actions (and (not *dumb-cue-copy-p*)
-          (fset:adjoinf files action))))
+                                        (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)

sync-music/utils.lisp

@@ -10,12 +10,17 @@
   "Whether to perform remove actions and delete empty folders.")
 (defvar *ignore-toplevel-p* t
   "Whether to ignore files at the top level.")
+(defvar *dumb-cue-copy-p* nil
+  "Whether to blindly copy cue files rather than parse them.")
 
 (defparameter *general-extensions* '("mp3" "ogg" "opus")
   "General file extensions that should be copied over.")
 (defparameter *meta-extensions* '("cue" "m3u" "m3u8")
   "File extensions where *.flac text needs to be replaced.")
 
+(defparameter *timestamp-scanner* (ppcre:create-scanner "^(\\d+):(\\d{2})\\.(\\d{2})$")
+  "Scan for a cuetools position.")
+
 (defun maybe-normalize-unicode (s)
   (if (stringp s) (uax-15:normalize s :nfc) s))
 
@@ -27,6 +32,29 @@
                  :type (maybe-normalize-unicode (pathname-type p))
                  :defaults p))
 
+(defmacro handle-overflow ((unit unit-max) (next-unit &optional next-max) &rest args)
+  "Handle integer overflow from UNIT with maximum UNIT-MAX into NEXT-UNIT."
+  (with-gensyms (div rem)
+    `(when (>= ,unit ,unit-max)
+       (multiple-value-bind (,div ,rem)
+           (floor ,unit ,unit-max)
+         (setf ,unit ,rem)
+         (incf ,next-unit ,div))
+       ,(when next-max
+          `(handle-overflow (,next-unit ,next-max) ,@args)))))
+
+(defun convert-timestamp (s)
+  "Convert cuetools position MM:SS.FF to ffmpeg duration MM:SS.m."
+  (let* ((all-times (nth-value 1 (ppcre:scan-to-strings *timestamp-scanner* s)))
+         (hours 0)
+         (minutes (parse-integer (aref all-times 0)))
+         (seconds (parse-integer (aref all-times 1)))
+         (frames (parse-integer (aref all-times 2)))
+         (millis (round (* frames 1000) 75)))
+    (handle-overflow (millis 1000) (seconds 60) (minutes))
+    (handle-overflow (minutes 60) (hours))
+    (format nil "~D:~2,'0D:~2,'0D.~3,'0D" hours minutes seconds millis)))
+
 (defun vector-nconc-extend (v1 v2 &key (start 0) end)
   "Like vector-append-extend, but using another vector.