|
|
@@ -0,0 +1,323 @@
|
|
|
+(in-package :cl-user)
|
|
|
+(defpackage chad-music.db
|
|
|
+ (:use :cl #:audio-streams #:alexandria))
|
|
|
+(in-package :chad-music.db)
|
|
|
+
|
|
|
+(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
|
+ #+dbg
|
|
|
+ (defvar *standard-optimize-settings* '(optimize (debug 3)))
|
|
|
+ #-dbg
|
|
|
+ (defvar *standard-optimize-settings* '(optimize (speed 3) (safety 0) (space 0) (debug 0)))
|
|
|
+ )
|
|
|
+
|
|
|
+(defstruct album
|
|
|
+ album-artist year album original-date part-of-set
|
|
|
+ genre album-type album-status mb-id track-count total-duration cover)
|
|
|
+
|
|
|
+(defstruct track2
|
|
|
+ album artist track-no title
|
|
|
+ bit-rate is-vbr duration)
|
|
|
+
|
|
|
+(defstruct track
|
|
|
+ album-artist artist year album original-date genre album-type album-status mb-id
|
|
|
+ track-no part-of-set title
|
|
|
+ bit-rate is-vbr duration
|
|
|
+ ;; (album-artist nil :type (or string null))
|
|
|
+ ;; (artist nil :type (or null string))
|
|
|
+ ;; (year nil :type (or null fixnum))
|
|
|
+ ;; (album nil :type (or null string))
|
|
|
+ ;; (original-date nil :type (or null string))
|
|
|
+ ;; (genre nil :type (or null string))
|
|
|
+ ;; (album-type nil :type (or null string))
|
|
|
+ ;; (album-status nil :type (or null string))
|
|
|
+ ;; (mb-id nil :type (or null string))
|
|
|
+ ;; (track-no nil :type (or null fixnum list))
|
|
|
+ ;; part-of-set
|
|
|
+ ;; (title nil :type (or null string))
|
|
|
+ ;; (bit-rate nil :type (or null fixnum))
|
|
|
+ ;; (is-vbr nil :type (or null boolean))
|
|
|
+ ;; (duration nil :type (or null fixnum))
|
|
|
+ )
|
|
|
+
|
|
|
+(defgeneric text-tag (stream desc) (:method ((object t) desc) nil))
|
|
|
+(defmethod text-tag ((mp3 id3:mp3-file) desc)
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (loop for frame in (id3:get-frames mp3 '("TXXX"))
|
|
|
+ when (string-equal (id3:desc frame) desc)
|
|
|
+ do (return-from text-tag (id3:val frame))))
|
|
|
+
|
|
|
+(defgeneric bit-rate (stream) (:method ((object t)) nil))
|
|
|
+(defgeneric is-vbr (stream) (:method ((object t)) nil))
|
|
|
+(defgeneric duration (stream) (:method ((object t)) nil))
|
|
|
+(defmethod bit-rate ((mp3 id3:mp3-file))
|
|
|
+ (let ((info (id3:audio-info mp3)))
|
|
|
+ (when info
|
|
|
+ (round (mpeg::bit-rate info) 1000))))
|
|
|
+
|
|
|
+(defmethod is-vbr ((mp3 id3:mp3-file))
|
|
|
+ (let ((info (id3:audio-info mp3)))
|
|
|
+ (when info
|
|
|
+ (mpeg::is-vbr info))))
|
|
|
+
|
|
|
+(defmethod duration ((mp3 id3:mp3-file))
|
|
|
+ (let ((info (id3:audio-info mp3)))
|
|
|
+ (when info
|
|
|
+ (mpeg::len info))))
|
|
|
+
|
|
|
+(defmethod bit-rate ((m4a m4a:mp4-file))
|
|
|
+ (let ((info (m4a:audio-info m4a)))
|
|
|
+ (when info
|
|
|
+ (round (m4a::avg-bit-rate info) 1000))))
|
|
|
+
|
|
|
+(defmethod duration ((m4a m4a:mp4-file))
|
|
|
+ (let ((info (m4a:audio-info m4a)))
|
|
|
+ (when info
|
|
|
+ (m4a::seconds info))))
|
|
|
+
|
|
|
+(defun parse-file (file)
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (let ((it (open-audio-file file)))
|
|
|
+ (when it
|
|
|
+ (make-track
|
|
|
+ :album-artist (abstract-tag:album-artist it)
|
|
|
+ :artist (abstract-tag:artist it)
|
|
|
+ :year (utils:awhen (abstract-tag::year it) (parse-integer utils:it :junk-allowed t))
|
|
|
+ :album (abstract-tag:album it)
|
|
|
+ :original-date (abstract-tag:original-date it)
|
|
|
+ :genre (abstract-tag::genre it)
|
|
|
+ :album-type (string-downcase (text-tag it "MusicBrainz Album Type"))
|
|
|
+ :album-status (string-downcase (text-tag it "MusicBrainz Album Status"))
|
|
|
+ :mb-id (text-tag it "MusicBrainz Album Id")
|
|
|
+ :track-no (abstract-tag::track it)
|
|
|
+ :part-of-set (abstract-tag::disk it)
|
|
|
+ :title (abstract-tag:title it)
|
|
|
+ :bit-rate (bit-rate it)
|
|
|
+ :is-vbr (is-vbr it)
|
|
|
+ :duration (duration it)))))
|
|
|
+
|
|
|
+(defun album-id (album-artist year album-title)
|
|
|
+ (crypto:byte-array-to-hex-string
|
|
|
+ (crypto:digest-sequence :md5 (flex:string-to-octets
|
|
|
+ (format nil "~A-~A-~A" album-artist year album-title)
|
|
|
+ :external-format :utf-8))))
|
|
|
+
|
|
|
+(defun parse-file2 (file albums-db)
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (let ((it (open-audio-file file)))
|
|
|
+ (when it
|
|
|
+ (let* ((album-artist (abstract-tag:album-artist it))
|
|
|
+ (year (utils:awhen (abstract-tag::year it) (parse-integer utils:it :junk-allowed t)))
|
|
|
+ (album-title (abstract-tag:album it))
|
|
|
+ (album-id (album-id album-artist year album-title)))
|
|
|
+ (multiple-value-bind (album foundp) (gethash album-id albums-db)
|
|
|
+ (unless foundp
|
|
|
+ (setf album (make-album
|
|
|
+ :album-artist album-artist
|
|
|
+ :year year
|
|
|
+ :album album-title
|
|
|
+ :original-date (abstract-tag:original-date it)
|
|
|
+ :genre (abstract-tag::genre it)
|
|
|
+ :part-of-set (abstract-tag::disk it)
|
|
|
+ :album-type (string-downcase (text-tag it "MusicBrainz Album Type"))
|
|
|
+ :album-status (string-downcase (text-tag it "MusicBrainz Album Status"))
|
|
|
+ :mb-id (text-tag it "MusicBrainz Album Id"))
|
|
|
+ (gethash album-id albums-db) album))
|
|
|
+ (make-track2
|
|
|
+ :album album
|
|
|
+ :artist (abstract-tag:artist it)
|
|
|
+ :track-no (abstract-tag::track it)
|
|
|
+ :title (abstract-tag:title it)
|
|
|
+ :bit-rate (bit-rate it)
|
|
|
+ :is-vbr (is-vbr it)
|
|
|
+ :duration (duration it)))))))
|
|
|
+
|
|
|
+(defstruct entry path data added modified present)
|
|
|
+
|
|
|
+(defun file-id (file)
|
|
|
+ (crypto:byte-array-to-hex-string
|
|
|
+ (crypto:digest-sequence :md5 (flex:string-to-octets (namestring file) :external-format :utf-8))))
|
|
|
+
|
|
|
+(defun rescan (paths &optional (db (make-hash-table :test 'equal)))
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (let ((added 0) (updated 0) (removed 0))
|
|
|
+ (declare (fixnum added updated removed))
|
|
|
+
|
|
|
+ (loop for value being the hash-values in db
|
|
|
+ do (setf (entry-present value) nil))
|
|
|
+
|
|
|
+ (unless (listp paths)
|
|
|
+ (setf paths (list paths)))
|
|
|
+
|
|
|
+ (labels ((scan-file (file)
|
|
|
+ (let ((file-id (file-id file)))
|
|
|
+ (multiple-value-bind (entry foundp)
|
|
|
+ (gethash file-id db)
|
|
|
+ (let ((modified (file-write-date file)))
|
|
|
+ (unless foundp
|
|
|
+ (incf added)
|
|
|
+ (setf entry (make-entry :path file :added (get-universal-time))
|
|
|
+ (gethash file-id db) entry))
|
|
|
+ (unless (and foundp (= (the fixnum (entry-modified entry)) modified))
|
|
|
+ (when foundp (incf updated))
|
|
|
+ (setf (entry-data entry) (parse-file file)
|
|
|
+ (entry-modified entry) modified))
|
|
|
+ (setf (entry-present entry) t))))))
|
|
|
+ (dolist (dir paths)
|
|
|
+ (cl-fad:walk-directory dir #'scan-file :follow-symlinks nil))
|
|
|
+
|
|
|
+ (loop for file being the hash-keys in db using (hash-value entry)
|
|
|
+ unless (entry-present entry)
|
|
|
+ do (incf removed) and
|
|
|
+ do (remhash file db))
|
|
|
+
|
|
|
+ (values db added updated removed))))
|
|
|
+
|
|
|
+(defun rescan2 (paths &optional (dbs (cons (make-hash-table :test 'equal) (make-hash-table :test 'equal))))
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (let ((added 0) (updated 0) (removed 0)
|
|
|
+ (tracks-db (car dbs))
|
|
|
+ (albums-db (cdr dbs)))
|
|
|
+ (declare (fixnum added updated removed))
|
|
|
+
|
|
|
+ (loop for value being the hash-values in tracks-db
|
|
|
+ do (setf (entry-present value) nil))
|
|
|
+
|
|
|
+ (unless (listp paths)
|
|
|
+ (setf paths (list paths)))
|
|
|
+
|
|
|
+ (labels ((scan-file (file)
|
|
|
+ (let ((file-id (file-id file)))
|
|
|
+ (multiple-value-bind (entry foundp)
|
|
|
+ (gethash file-id tracks-db)
|
|
|
+ (let ((modified (file-write-date file)))
|
|
|
+ (unless foundp
|
|
|
+ (incf added)
|
|
|
+ (setf entry (make-entry :path file :added (get-universal-time))
|
|
|
+ (gethash file-id tracks-db) entry))
|
|
|
+ (unless (and foundp (= (the fixnum (entry-modified entry)) modified))
|
|
|
+ (when foundp (incf updated))
|
|
|
+ (setf (entry-data entry) (parse-file2 file albums-db)
|
|
|
+ (entry-modified entry) modified))
|
|
|
+ (setf (entry-present entry) t))))))
|
|
|
+ (dolist (dir paths)
|
|
|
+ (cl-fad:walk-directory dir #'scan-file :follow-symlinks nil))
|
|
|
+
|
|
|
+ (let ((album-stats (make-hash-table)))
|
|
|
+ (loop for file being the hash-keys in tracks-db using (hash-value entry)
|
|
|
+ do (if (entry-present entry)
|
|
|
+ (alexandria:when-let (track (entry-data entry))
|
|
|
+ (incf (car (gethash (track))))
|
|
|
+ )
|
|
|
+ (progn
|
|
|
+ (incf removed)
|
|
|
+ (remhash file tracks-db)))))
|
|
|
+
|
|
|
+ (values (cons tracks-db albums-db) added updated removed))))
|
|
|
+
|
|
|
+(defparameter +album-type-order+ '("album" "lp" "ep" "single" "compilation" "live" "soundtrack"
|
|
|
+ "spokenword" "remix" "mixed" "dj-mix" "mixtape" "broadcast")
|
|
|
+ "Half-arbitrary album type order")
|
|
|
+(defun track-comparator (slots)
|
|
|
+ (labels ((clear-track-no (track-no)
|
|
|
+ (when track-no
|
|
|
+ (parse-integer (if (consp track-no)
|
|
|
+ (car track-no)
|
|
|
+ track-no)
|
|
|
+ :junk-allowed t))))
|
|
|
+ (alexandria:named-lambda info< (a b)
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+ (dolist (slot slots)
|
|
|
+ (let ((slot-a (slot-value a slot))
|
|
|
+ (slot-b (slot-value b slot)))
|
|
|
+ (when (xor (null slot-a) (null slot-b))
|
|
|
+ (return-from info< (null slot-b)))
|
|
|
+ (case slot
|
|
|
+ (album-type
|
|
|
+ (setf slot-a (or (position slot-a +album-type-order+ :test 'string-equal) 0)
|
|
|
+ slot-b (or (position slot-b +album-type-order+ :test 'string-equal) 0)))
|
|
|
+ (track-no
|
|
|
+ (setf slot-a (clear-track-no slot-a)
|
|
|
+ slot-b (clear-track-no slot-b))))
|
|
|
+ (unless (or (and (null slot-a) (null slot-b))
|
|
|
+ (case slot
|
|
|
+ ((album-type year track-no) (= slot-a slot-b))
|
|
|
+ (t (string-equal slot-a slot-b))))
|
|
|
+ (return-from info< (case slot
|
|
|
+ ((album-type year track-no) (< slot-a slot-b))
|
|
|
+ (t (string< slot-a slot-b))))))))))
|
|
|
+
|
|
|
+(defun match-filter (data category filter)
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (or (null filter)
|
|
|
+ (let ((words (split-sequence:split-sequence #\Space filter)))
|
|
|
+ (every #'(lambda (word)
|
|
|
+ (case category
|
|
|
+ (album (or (search word (track-album data) :test 'char-equal)
|
|
|
+ (search word (track-album-artist data) :test 'char-equal)))
|
|
|
+ (year (search word (princ-to-string (track-year data)) :test 'char-equal))
|
|
|
+ (t (search word (slot-value data category) :test 'char-equal))))
|
|
|
+ words))))
|
|
|
+
|
|
|
+(defun match-restrictions (data restrictions)
|
|
|
+ (declare #.*standard-optimize-settings*)
|
|
|
+
|
|
|
+ (every #'(lambda (r)
|
|
|
+ (equal (slot-value data (car r)) (cdr r)))
|
|
|
+ restrictions))
|
|
|
+
|
|
|
+(defun query-category (db category &key filter restrictions limit (offset 0))
|
|
|
+ (declare #.*standard-optimize-settings*
|
|
|
+ (type (or null fixnum) limit offset))
|
|
|
+
|
|
|
+ (labels ((category-data (data category)
|
|
|
+ (case category
|
|
|
+ (album (with-slots (album-artist year album original-date genre album-type album-status mb-id) data
|
|
|
+ (make-album :album-artist album-artist
|
|
|
+ :year year
|
|
|
+ :album album
|
|
|
+ :original-date original-date
|
|
|
+ :genre genre
|
|
|
+ :album-type album-type
|
|
|
+ :album-status album-status
|
|
|
+ :mb-id mb-id)))
|
|
|
+ (t (slot-value data category)))))
|
|
|
+ (let ((results (make-hash-table :test 'equalp)))
|
|
|
+ (loop for entry being the hash-value of db
|
|
|
+ for data = (entry-data entry)
|
|
|
+ when (and data
|
|
|
+ (match-restrictions data restrictions)
|
|
|
+ (match-filter data category filter))
|
|
|
+ do (setf (gethash (category-data data category) results) t))
|
|
|
+ (let* ((total (hash-table-count results))
|
|
|
+ (start (min total offset))
|
|
|
+ (end (min total (+ offset limit))))
|
|
|
+ (subseq (sort (hash-table-keys results)
|
|
|
+ (case category
|
|
|
+ (album (track-comparator '(album-artist album-type original-date year album)))
|
|
|
+ (year #'<)
|
|
|
+ (t #'string<)))
|
|
|
+ start end)))))
|
|
|
+
|
|
|
+(defun query-tracks (db &key filter restrictions limit (offset 0))
|
|
|
+ (declare #.*standard-optimize-settings*
|
|
|
+ (type (or null fixnum) limit offset))
|
|
|
+ (let (results)
|
|
|
+ (loop for entry being the hash-value of db
|
|
|
+ for data = (entry-data entry)
|
|
|
+ when (and data
|
|
|
+ (match-restrictions data restrictions)
|
|
|
+ (match-filter data 'title filter))
|
|
|
+ do (push (cons (entry-path entry) data) results))
|
|
|
+ (let* ((total (length results))
|
|
|
+ (start (min total offset))
|
|
|
+ (end (min total (+ offset limit))))
|
|
|
+ (subseq (sort results
|
|
|
+ (track-comparator '(album-artist album-type original-date year album track-no title))
|
|
|
+ :key 'cdr)
|
|
|
+ start end))))
|
