chad-music/db.lisp

(in-package :cl-user)
(defpackage chad-music.db
  (:use :cl #:audio-streams #:alexandria #:chad-music.utils)
  (:export #:*standard-optimize-settings*
           #:album #:id #:artist #:year #:album #:original-date #:genre #:type #:status #:mb-id #:track-count #:total-duration #:cover
           #:make-album #:album-id #:album-artist #:album-year #:album-album #:album-original-date
           #:album-genre #:album-type #:album-status #:album-mb-id #:album-track-count #:album-total-duration #:album-cover
           #:track #:no #:title #:part-of-set #:bit-rate #:is-vbr #:duration #:path
           #:make-track #:track-album #:track-artist #:track-no #:track-title #:track-part-of-set
           #:track-bit-rate #:track-is-vbr #:track-duration #:track-path
           #:entry #:track #:added #:modified #:present
           #:make-entry #:entry-track #:entry-added #:entry-modified #:entry-present
           #:get-album-id #:get-file-id #:rescan
           #:clear-track-no
           #:query-category #:query-tracks))
(in-package :chad-music.db)

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

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

(defstruct entry track added modified present)

(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 (artist year title)
  (crypto:byte-array-to-hex-string
   (crypto:digest-sequence :md5 (flex:string-to-octets
                                 (format nil "~A-~A-~A" artist year 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
                         :artist album-artist
                         :year year
                         :album album-title
                         :original-date (abstract-tag:original-date it)
                         :genre (abstract-tag::genre it)
                         :type (utils:awhen (text-tag it "MusicBrainz Album Type") (string-downcase utils:it))
                         :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)
           :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))
           :path file))))))

(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 :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-track 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-track 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 (track-path track))
                                               "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))))

(defun clear-track-no (track-no)
  (when track-no
    (parse-integer (if (consp track-no)
                       (car track-no)
                       track-no)
                   :junk-allowed t)))

(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)
  (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
          (type
           (setf slot-a (or (position slot-a (the list +album-type-order+) :test 'string-equal) 0)
                 slot-b (or (position slot-b (the list +album-type-order+) :test 'string-equal) 0)))
          (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
                      ((type year no) (= (the fixnum slot-a) (the fixnum slot-b)))
                      (t (string-equal slot-a slot-b))))
          (return-from info<> (case slot
                                ((type year no) (- (the fixnum slot-a) (the fixnum slot-b)))
                                (t (if (string< slot-a slot-b) -1 1)))))))))
(defparameter +album<>+ (gen-comparator '(artist type original-date year album)))
(defun album< (a b)
  (< (funcall +album<>+ a b) 0))

(defparameter +track<>+ (gen-comparator '(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)
                   (declare (simple-string word))
                   (case category
                     (album (or (search word (the simple-string (album-album data)) :test 'char-equal)
                                (search word (the simple-string (album-artist data)) :test 'char-equal)))
                     (year (or (and (album-year data)
                                    (search word (princ-to-string (the fixnum (album-year data))) :test 'char-equal))
                               (and (album-original-date data)
                                    (search word (the simple-string (album-original-date data)) :test 'char-equal))))
                     (t (and (slot-value data category)
                             (search word (the simple-string (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) count-only)
  (declare #.*standard-optimize-settings*
           (type (or null fixnum) limit offset))
  (let ((results (make-hash-table :test (case category
                                          (album 'eq)
                                          (t 'equal)))))
    (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))))
      (if count-only total
          (subseq (the list (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 track = (entry-track entry)
       when (and track
                 (match-restrictions (track-album track) restrictions)
                 (match-filter track 'title filter))
       do (push track results))
    (let* ((total (length results))
           (start (min total offset))
           (end (min total (+ offset limit))))
      (subseq (sort results
                    #'track<)
              start end))))