chad-music/back/db.lisp

(in-package :cl-user)
(defpackage chad-music.db
  (:use :cl #:audio-streams #:alexandria #:chad-music.utils)
  (:export #:*standard-optimize-settings*
           #:*db-path*
           #:*db*
           #:album #:id #:artist #:year #:album #:original-date #:publisher #:country #:genre #:type #:status #:mb-id #:track-count #:total-duration #:cover
           #:make-album #:album-id #:album-artist #:album-year #:album-album #:album-original-date #:album-publisher #:album-country
           #: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-id #: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
           #:db-stats
           #:save-db #:load-db
           #:query-category #:query-tracks #:album-tracks))
(in-package :chad-music.db)

(defstruct db
  (albums (make-hash-table :test 'equal) :type hash-table)
  (tracks (make-hash-table :test 'equal) :type hash-table)
  (album-tracks (make-hash-table :test 'equal) :type hash-table)
  (album-added (make-hash-table :test 'equal) :type hash-table))

(defvar *db* (make-db) "Metadata database")
(defvar *db-path* "music.sexp" "Default file to save/load database")

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

(defstruct track
  id album-id 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 track-id)
  (declare #.*standard-optimize-settings*)

  (let ((it (open-audio-file file)))
    (when it
      (let* ((albums-db (db-albums *db*))
             (album-artist (or (abstract-tag:album-artist it)
                               (abstract-tag:artist it)))
             (album-year (utils:awhen (or (abstract-tag::year it)
                                          (abstract-tag:original-date it))
                           (etypecase utils:it
                             (integer utils:it)
                             (string (parse-integer utils:it :junk-allowed t)))))
             (album-title (abstract-tag:album it))
             (album-id (get-album-id album-artist album-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 album-year
                         :album album-title
                         :original-date (abstract-tag:original-date it)
                         :publisher (publisher it)
                         :country (country 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
           :id track-id
           :album-id album-id
           :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 (or (duration it) 0))
           :path file))))))

(defun track-album (track)
  (gethash (track-album-id track)
           (db-albums *db*)))

(defun rescan (paths)
  (declare #.*standard-optimize-settings*)

  (let ((added 0) (updated 0) (removed 0)
        (albums-db (db-albums *db*))
        (tracks-db (db-tracks *db*)))
    (declare (fixnum added updated removed))

    (loop for value being the hash-values in tracks-db
       do (let ((track (entry-track value)))
            (when (and track
                       (some (lambda (dir)
                               (starts-with-subseq (namestring dir)
                                                   (namestring (track-path track))))
                             paths))
              (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 file-id)
                             (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-id being the hash-keys in albums-db using (hash-value album)
           for stats = (gethash album album-stats)
           do (if stats
                  (setf (album-track-count album) (car stats)
                        (album-total-duration album) (cdr stats))
                  (remhash album-id albums-db))))
      (reindex-db)
      (values added updated removed))))

(defun reindex-db ()
  (declare #.*standard-optimize-settings*)

  (let ((tracks-db (db-tracks *db*))
        (album-tracks-db (db-album-tracks *db*))
        (album-added-db (db-album-added *db*)))
    (clrhash album-tracks-db)
    (clrhash album-added-db)
    (loop for entry being the hash-values in tracks-db
       for track = (entry-track entry)
       when track
       do (setf (gethash (track-album-id track) album-added-db) (entry-added entry))
       and do (push track (gethash (track-album-id track) album-tracks-db)))
    (loop for album-id being the hash-keys in album-tracks-db using (hash-value tracks)
       do (setf (gethash album-id album-tracks-db)
                (sort tracks 'track<)))))

(defun clear-track-no (track-no)
  (when track-no
    (let ((track (if (consp track-no)
                     (car track-no)
                     track-no)))
      (etypecase track
        (null nil)
        (integer track)
        (string (parse-integer track :junk-allowed t))))))

(defun slot< (a b)
  (declare #.*standard-optimize-settings*
           (type simple-string a b))
  (when (xor (emptyp a) (emptyp b))
    (return-from slot< (when (emptyp b) 0)))
  (let ((aa (alpha-char-p (elt a 0)))
        (ba (alpha-char-p (elt b 0))))
    (cond
      ((and aa ba) (string< a b))
      (aa 0)
      (ba)
      (t (string< a b)))))

(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)))
        (unless (and (null slot-a) (null slot-b))
          (case slot
            (type
             (let ((cmp (if (slot< slot-a slot-b) -1 1)))
               (setf slot-a (or (position slot-a (the list +album-type-order+) :test 'string-equal)
                                (+ 100 cmp))
                     slot-b (or (position slot-b (the list +album-type-order+) :test 'string-equal)
                                (- 100 cmp)))))
            (no
             (setf slot-a (clear-track-no slot-a)
                   slot-b (clear-track-no slot-b))))
          (unless (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 (slot< slot-a slot-b) -1 1))))))))))

(defparameter +album<>+ (gen-comparator '(artist type year album)))
(defun album< (a b)
  (declare #.*standard-optimize-settings*
           (type function +album<>+))
  (< (the fixnum (funcall +album<>+ a b)) 0))

(defun album-added> (a b)
  (declare #.*standard-optimize-settings*
           (type album a b))
  (let ((album-added-db (db-album-added *db*)))
    (> (the fixnum (gethash (album-id a) album-added-db))
       (the fixnum (gethash (album-id b) album-added-db)))))

(defparameter +track<>+ (gen-comparator '(no title)))
(defun track< (a b)
  (declare #.*standard-optimize-settings*
           (type function +album<>+ +track<>+))
  (let ((albs (the fixnum (funcall +album<>+ (track-album a) (track-album b)))))
    (if (zerop albs)
        (< (the fixnum (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-artist data) :test 'char-equal)
                                (and (album-publisher data)
                                     (search word (album-publisher data) :test 'char-equal))
                                (and (album-country data)
                                     (search word (album-country 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 (album-original-date data) :test 'char-equal))))
                     (t (and (slot-value data category)
                             (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 (category &key filter restrictions limit (offset 0) count-only latest)
  (declare #.*standard-optimize-settings*
           (type (or null fixnum) limit offset))
  (let ((albums-db (db-albums *db*))
        (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 (incf (the fixnum (gethash result results 0))))
    (let* ((total (hash-table-count results))
           (start (min total offset))
           (end (min total (+ offset limit))))
      (if count-only total
          (subseq (the list (sort (case category
                                    (album (hash-table-keys results))
                                    (t (hash-table-alist results)))
                                  (case category
                                    (album (if latest #'album-added> #'album<))
                                    (year #'<)
                                    (t #'slot<))
                                  :key (case category
                                         (album nil)
                                         (t #'car))))
                  start end)))))

(defun query-tracks (&key filter restrictions limit (offset 0))
  (declare #.*standard-optimize-settings*
           (type (or null fixnum) limit offset))
  (let ((tracks-db (db-tracks *db*)) 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))))

(defun album-tracks (album-id)
  (gethash album-id (db-album-tracks *db*)))

(defun db-stats ()
  (declare #.*standard-optimize-settings*)
  (let ((albums (db-albums *db*))
    (artists (make-hash-table :test 'equal)))
    (loop for entry being the hash-values in albums
      summing (album-total-duration entry) into total-duration
      summing (album-track-count entry) into total-tracks
      counting t into total-albums
      do (setf (gethash (album-artist entry) artists) t)
      finally (return (list :|artists| (hash-table-count artists)
                            :|albums| total-albums
                            :|tracks| total-tracks
                            :|duration| total-duration)))))

(defun save-db (&optional (file-name *db-path*))
  (declare #.*standard-optimize-settings*)
  (with-output-to-file (s file-name :if-exists :supersede)
    (labels ((print-values (table)
               (loop for value being the hash-value of table
                  do (print value s))))
      (print-values (db-albums *db*))
      (print-values (db-tracks *db*)))))

(defun load-db (&optional (file-name *db-path*))
  (declare #.*standard-optimize-settings*)
  (with-input-from-file (s file-name)
    (let ((albums (make-hash-table :test 'equal))
          (entries (make-hash-table :test 'equal)))
      (loop for value = (read s nil)
         while value
         do (etypecase value
              (album (setf (gethash (album-id value) albums) value))
              (entry (when (entry-track value)
                       (setf (gethash (track-id (entry-track value)) entries) value)))))
      (let ((*db* (make-db :albums albums :tracks entries)))
        (reindex-db)
        *db*))))