chad-music/db.lisp

(in-package :cl-user)
(defpackage chad-music.db
  (:use :cl #:audio-streams #:alexandria #:chad-music.utils))
(in-package :chad-music.db)

(defstruct album
  id album-artist year album original-date
  genre album-type album-status mb-id track-count total-duration cover)

(defstruct track
  album artist track-no title part-of-set
  bit-rate is-vbr duration)

(defun get-file-id (file)
  (crypto:byte-array-to-hex-string
   (crypto:digest-sequence :md5 (flex:string-to-octets (namestring file) :external-format :utf-8))))

(defun get-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-file (file albums-db)
  (declare #.*standard-optimize-settings*)

  (let ((it (open-audio-file file)))
    (when it
      (let* ((album-artist (or (abstract-tag:album-artist it)
                               (abstract-tag:artist it)))
             (year (utils:awhen (abstract-tag::year it) (parse-integer utils:it :junk-allowed t)))
             (album-title (abstract-tag:album it))
             (album-id (get-album-id album-artist year album-title)))
        (multiple-value-bind (album foundp) (gethash album-id albums-db)
          (unless foundp
            (setf album (make-album
                         :id album-id
                         :album-artist album-artist
                         :year year
                         :album album-title
                         :original-date (abstract-tag:original-date it)
                         :genre (abstract-tag::genre it)
                         :album-type (utils:awhen (text-tag it "MusicBrainz Album Type") (string-downcase utils:it))
                         :album-status (utils:awhen (text-tag it "MusicBrainz Album Status") (string-downcase utils:it))
                         :mb-id (text-tag it "MusicBrainz Album Id"))
                  (gethash album-id albums-db) album))
          (make-track
           :album album
           :artist (abstract-tag:artist it)
           :track-no (abstract-tag::track it)
           :title (abstract-tag:title it)
           :part-of-set (abstract-tag::disk it)
           :bit-rate (bit-rate it)
           :is-vbr (is-vbr it)
           :duration (round (duration it))))))))

(defstruct entry path data added modified present)

(defun rescan (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 (get-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-file 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)
                  (when-let (track (entry-data entry))
                    (let ((album (track-album track)))
                      (multiple-value-bind (stats foundp) (gethash album album-stats)
                        (unless foundp
                          (setf stats (cons 0 0)
                                (gethash album album-stats) stats)
                          (unless (album-cover album)
                            (setf (album-cover album)
                                  (probe-file (cl-fad:merge-pathnames-as-file
                                               (cl-fad:pathname-directory-pathname (entry-path entry))
                                               "cover.jpg")))))
                        (incf (the fixnum (car stats))) ;; track-count
                        (incf (the fixnum (cdr stats))  ;; total-duration
                              (the fixnum (or (track-duration track) 0))))))
                  (progn
                    (incf removed)
                    (remhash file tracks-db))))
        (loop for album being the hash-keys in album-stats using (hash-value stats)
           do (setf (album-track-count album) (car stats)
                    (album-total-duration album) (cdr stats))))

      (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 gen-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))))
    (named-lambda info<> (a b)
      (declare #.*standard-optimize-settings*)
      (dolist (slot slots 0)
        (let ((slot-a (slot-value a slot))
              (slot-b (slot-value b slot)))
          (when (xor (null slot-a) (null slot-b))
            (return-from info<> (if (null slot-b) 1 -1)))
          (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 (if (string< slot-a slot-b) -1 1))))))))))
(defparameter +album<>+ (gen-comparator '(album-artist album-type original-date year album)))
(defun album< (a b)
  (< (funcall +album<>+ a b) 0))

(defparameter +track<>+ (gen-comparator '(track-no title)))
(defun track< (a b)
  (let ((albs (funcall +album<>+ (track-album a) (track-album b))))
    (if (zerop albs)
        (< (funcall +track<>+ a b) 0)
        albs)))

(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 (album-album data) :test 'char-equal)
                                (search word (album-album-artist data) :test 'char-equal)))
                     (year (or (search word (princ-to-string (album-year data)) :test 'char-equal)
                               (search word (album-original-date 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 (albums-db category &key filter restrictions limit (offset 0))
  (declare #.*standard-optimize-settings*
           (type (or null fixnum) limit offset))
o  (let ((results (make-hash-table :test (case category
                                          (album 'eq)
                                          (t 'equalp)))))
    (loop for data being the hash-value of albums-db
       for result = (case category
                      (album data)
                      (t (slot-value data category)))
       when (and
             result
             (match-restrictions data restrictions)
             (match-filter data category filter))
       do (setf (gethash result 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 #'album<)
                      (year #'<)
                      (t #'string<)))
              start end))))

(defun query-tracks (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 tracks-db
       for data = (entry-data entry)
       when (and data
                 (match-restrictions (track-album 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<
                    :key 'cdr)
              start end))))