chad-music/db.lisp

(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))))