woo webserver and test data generator

chad-music.asd

@@ -6,7 +6,16 @@
                #:alexandria
                #:cl-fad
                #:ironclad
-               #:split-sequence)
+               #:split-sequence
+               #:woo
+               #:clack
+               #:lack
+               #:quri
+               #:zip
+               #:trivial-utf-8
+               #:myway
+               #:jonathan)
   :serial t
   :components ((:file "utils")
-               (:file "db")))
+               (:file "db")
+               (:file "server")))

db.lisp

@@ -1,24 +1,38 @@
 (in-package :cl-user)
 (defpackage chad-music.db
-  (:use :cl #:audio-streams #:alexandria #:chad-music.utils))
+  (: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 album-artist year album original-date
-  genre album-type album-status mb-id track-count total-duration cover)
+  id artist year album original-date
+  genre type status mb-id track-count total-duration cover)
 
 (defstruct track
-  album artist track-no title part-of-set
-  bit-rate is-vbr duration)
+  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 (album-artist year album-title)
+(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" album-artist year album-title)
+                                 (format nil "~A-~A-~A" artist year title)
                                  :external-format :utf-8))))
 
 (defun parse-file (file albums-db)
@@ -35,26 +49,25 @@
           (unless foundp
             (setf album (make-album
                          :id album-id
-                         :album-artist album-artist
+                         :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))
+                         :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)
-           :track-no (abstract-tag::track 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))))))))
-
-(defstruct entry path data added modified present)
+           :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*)
@@ -77,11 +90,11 @@
                    (let ((modified (file-write-date file)))
                      (unless foundp
                        (incf added)
-                       (setf entry (make-entry :path file :added (get-universal-time))
+                       (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-data entry) (parse-file file albums-db)
+                       (setf (entry-track entry) (parse-file file albums-db)
                              (entry-modified entry) modified))
                      (setf (entry-present entry) t))))))
       (dolist (dir paths)
@@ -90,7 +103,7 @@
       (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))
+                  (when-let (track (entry-track entry))
                     (let ((album (track-album track)))
                       (multiple-value-bind (stats foundp) (gethash album album-stats)
                         (unless foundp
@@ -99,7 +112,7 @@
                           (unless (album-cover album)
                             (setf (album-cover album)
                                   (probe-file (cl-fad:merge-pathnames-as-file
-                                               (cl-fad:pathname-directory-pathname (entry-path entry))
+                                               (cl-fad:pathname-directory-pathname (track-path track))
                                                "cover.jpg")))))
                         (incf (the fixnum (car stats))) ;; track-count
                         (incf (the fixnum (cdr stats))  ;; total-duration
@@ -113,42 +126,43 @@
 
       (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)
-  (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)))
+  (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 '(track-no title)))
+(defparameter +track<>+ (gen-comparator '(no title)))
 (defun track< (a b)
   (let ((albs (funcall +album<>+ (track-album a) (track-album b))))
     (if (zerop albs)
@@ -161,12 +175,16 @@
   (or (null filter)
       (let ((words (split-sequence:split-sequence #\Space filter)))
         (every #'(lambda (word)
+                   (declare (simple-string 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))))
+                     (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)
@@ -176,12 +194,12 @@
              (equal (slot-value data (car r)) (cdr r)))
          restrictions))
 
-(defun query-category (albums-db category &key filter restrictions limit (offset 0))
+(defun query-category (albums-db category &key filter restrictions limit (offset 0) count-only)
   (declare #.*standard-optimize-settings*
            (type (or null fixnum) limit offset))
-o  (let ((results (make-hash-table :test (case category
+  (let ((results (make-hash-table :test (case category
                                           (album 'eq)
-                                          (t 'equalp)))))
+                                          (t 'equal)))))
     (loop for data being the hash-value of albums-db
        for result = (case category
                       (album data)
@@ -194,27 +212,27 @@ o  (let ((results (make-hash-table :test (case category
     (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))))
+      (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 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))
+       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<
-                    :key 'cdr)
+                    #'track<)
               start end))))

server.lisp

@@ -0,0 +1,142 @@
+(in-package :cl-user)
+(defpackage chad-music.server
+  (:use :cl #:alexandria #:chad-music.db #:jonathan))
+(in-package :chad-music.server)
+
+(defvar *db* nil "Metadata database")
+
+(defvar *path-url-mappings*
+  '(("/media/pogo/Music/" . "/music/")) "Map database paths to urls")
+
+(defun get-url (path)
+  (when (and path (pathnamep path))
+    (let ((path (namestring path)))
+      (loop for (path-prefix . url-prefix) in *path-url-mappings*
+         do (multiple-value-bind (foundp suffix) (starts-with-subseq path-prefix path :return-suffix t)
+              (when foundp
+                (return-from get-url (concatenate 'string url-prefix suffix))))))))
+
+(declaim (inline js-null))
+(defun js-null (obj)
+  (if obj obj
+      :null))
+
+(defmethod %to-json ((album album))
+  (with-object
+    (write-key-value "id" (js-null (album-id album)))
+    (write-key-value "artist" (js-null (album-artist album)))
+    (write-key-value "year" (js-null (album-year album)))
+    (write-key-value "album" (js-null (album-album album)))
+    (write-key-value "original_date" (js-null (album-original-date album)))
+    (write-key-value "genre" (js-null (album-genre album)))
+    (write-key-value "type" (js-null (album-type album)))
+    (write-key-value "status" (js-null (album-status album)))
+    (write-key-value "mb_id" (js-null (album-mb-id album)))
+    (write-key-value "track_count" (js-null (album-track-count album)))
+    (write-key-value "total_duration" (js-null (album-total-duration album)))
+    (write-key-value "cover" (js-null (get-url (album-cover album))))))
+
+(defmethod %to-json ((track track))
+  (with-object
+    (write-key-value "artist" (js-null (track-artist track)))
+    (write-key-value "album" (js-null (album-album (track-album track))))
+    (write-key-value "no" (js-null (clear-track-no (track-no track))))
+    (write-key-value "title" (js-null (track-title track)))
+    (write-key-value "bit_rate" (js-null (track-bit-rate track)))
+    (write-key-value "vbr" (if (track-is-vbr track) :true :false))
+    (write-key-value "duration" (js-null (track-duration track)))
+    (write-key-value "url" (js-null (get-url (track-path track))))))
+
+(defparameter +400+ '(400 nil #.(trivial-utf-8:string-to-utf-8-bytes "400")))
+(defparameter +404+ '(404 nil #.(trivial-utf-8:string-to-utf-8-bytes "404")))
+(defparameter +200-empty+ '(200 (:content-type "application/json")
+                            #.(trivial-utf-8:string-to-utf-8-bytes "{}")))
+
+(defun 200-json (data)
+  (declare #.*standard-optimize-settings*)
+  `(200 (:content-type "application/json")
+        ,(trivial-utf-8:string-to-utf-8-bytes (to-json data))))
+
+(defun get-category-list (params)
+  (declare #.*standard-optimize-settings*
+           (ignore params))
+  (200-json '("artist" "year" "album" "genre" "type" "status")))
+
+(let ((db-package (find-package :chad-music.db)))
+  (defun getsym (place indicator)
+    (declare #.*standard-optimize-settings*
+             (type list place)
+             (type symbol indicator))
+    (intern (string-upcase (getf place indicator)) db-package)))
+
+(defun aget (place indicator &key (test #'equal))
+  (declare #.*standard-optimize-settings*
+           (type list place)
+           (type (or string symbol) indicator)
+           (type function test))
+  (cdr (assoc indicator place :test test)))
+
+(defun may-integer (string)
+  (declare #.*standard-optimize-settings*
+           (type (or null string) string))
+  (when string
+    (parse-integer string)))
+
+(defun get-restrictions (query-params)
+  (declare #.*standard-optimize-settings*
+           (type list query-params))
+  (loop for key in '(artist year album genre type status)
+     for value = (aget query-params (string-downcase (symbol-name key)))
+     when value collect (cons key (case key
+                                    (year (parse-integer value :junk-allowed t))
+                                    (otherwise value)))))
+
+(defparameter +max-limit+ 1000)
+(defmacro with-category ((params category filter restrictions offset limit) &body body)
+  (with-gensyms (query-string query-params)
+    `(let ((,category (getsym ,params :category)))
+       (case ,category
+         ((artist year album genre type status)
+          (let* ((,query-string (getf myway:*env* :query-string))
+                 (,query-params (and ,query-string (quri:url-decode-params ,query-string)))
+                 (,filter (aget ,query-params "filter"))
+                 (,restrictions (get-restrictions ,query-params))
+                 (,offset (or (may-integer (aget ,query-params "offset")) 0))
+                 (,limit (min (the fixnum +max-limit+) (the fixnum (or (may-integer (aget ,query-params "limit")) +max-limit+)))))
+            ,@body))
+         (otherwise +404+)))))
+
+(defun get-category-size (params)
+  (declare #.*standard-optimize-settings*)
+  (with-category (params category filter restrictions offset limit)
+    (declare (ignore offset limit))
+    (200-json (query-category (cdr *db*) category :filter filter :restrictions restrictions :count-only t))))
+
+(defun get-category (params)
+  (declare #.*standard-optimize-settings*)
+  (with-category (params category filter restrictions offset limit)
+    (200-json (query-category (cdr *db*) category
+                              :filter filter :restrictions restrictions
+                              :limit limit :offset offset))))
+
+(defun album-tracks (params)
+  (declare #.*standard-optimize-settings*)
+  (200-json (query-tracks (car *db*)
+                          :restrictions `((id . ,(getf params :id))))))
+
+(defvar *mapper* (myway:make-mapper))
+(myway:connect *mapper* "/cat/:category/size" 'get-category-size)
+(myway:connect *mapper* "/cat/:category" 'get-category)
+(myway:connect *mapper* "/cat" 'get-category-list)
+(myway:connect *mapper* "/album/:id/tracks" 'album-tracks)
+;;(myway:connect *mapper* "*" (lambda (p) (declare (ignore p)) +404+))
+
+(defun main (&rest args &key (port 5000) (debug nil) (use-thread t) &allow-other-keys)
+  (apply #'clack:clackup
+         (myway:to-app *mapper*)
+         :server :woo
+         :port port
+         :debug debug
+         :use-default-middlewares nil
+         :use-thread use-thread
+         (alexandria:remove-from-plist args :data :port :debug :use-thread)))

test.lisp

@@ -0,0 +1,91 @@
+(in-package :cl-user)
+(defpackage chad-music.test
+  (:use :cl #:audio-streams #:alexandria #:chad-music.db))
+(in-package :chad-music.test)
+
+(defparameter +album-split-slots+ '(artist album))
+(defparameter +album-whole-slots+ '(year genre type status))
+
+(defun gen-name (elements length)
+  (format nil "~{~A~^ ~}" (loop for i below (1+ (random length)) collect (random-elt elements))))
+(defun generate-albums (count albums-db)
+  (let ((splits (loop for slot in +album-split-slots+ append (list slot (make-hash-table :test 'equal))))
+        (wholes (loop for slot in +album-whole-slots+ append (list slot (make-hash-table :test 'equal))))
+        (albums (make-hash-table :test 'equal)))
+    (loop for album being the hash-values of albums-db
+       do (dolist (slot +album-split-slots+)
+            (loop for word in (split-sequence:split-sequence #\Space (slot-value album slot))
+               when (> (length word) 1)
+               do (setf (gethash word (getf splits slot)) t)))
+       do (dolist (slot +album-whole-slots+)
+            (setf (gethash (slot-value album slot) (getf wholes slot)) t)))
+    (dolist (slot +album-split-slots+)
+      (setf (getf splits slot) (hash-table-keys (getf splits slot))))
+    (dolist (slot +album-whole-slots+)
+      (setf (getf wholes slot) (hash-table-keys (getf wholes slot))))
+    (loop while (> count 0)
+       do (let ((artist (gen-name (getf splits 'artist) 3))
+                (num-albums (1+ (random 7))))
+            (loop for i below num-albums
+               for year = (random-elt (getf wholes 'year))
+               for title = (gen-name (getf splits 'album) 5) then
+                 (gen-name (getf splits 'album) 5)
+               for id = (get-album-id artist year title)
+               while (> count 0)
+               do (decf count)
+               do (setf (gethash id albums)
+                        (make-album
+                         :id id
+                         :artist artist
+                         :year year
+                         :album title
+                         :original-date (format nil "~4,'0D-~2,'0D-~2,'0D"
+                                                year (1+ (random 12)) (1+ (random 31)))
+                         :genre (random-elt (getf wholes 'genre))
+                         :type (random-elt (getf wholes 'type))
+                         :status (random-elt (getf wholes 'status))
+                         :cover (format nil "~A/~A/~D - ~A/cover.jpg" (elt artist 0) artist year title))))))
+    albums))
+
+(defparameter +bit-rates+ '(128 160 192 228 320))
+(defun generate-tracks (max-album-length test-albums-db tracks-db)
+  (let ((track-words (make-hash-table :test 'equal))
+        (tracks (make-hash-table :test 'equal)))
+    (loop for entry being the hash-values of tracks-db
+       for track = (entry-data entry)
+       when track
+       do (loop for word in (split-sequence:split-sequence #\Space (track-title track))
+             do (setf (gethash word track-words) t)))
+    (setf track-words (hash-table-keys track-words))
+    (loop for album being the hash-values of test-albums-db
+       for track-count = (+ 2 (random (- max-album-length 1)))
+       for bit-rate = (random-elt +bit-rates+)
+       for is-vbr = (zerop (random 2))
+       do (setf (album-track-count album) track-count
+                (album-total-duration album) 0)
+       do (loop for i below track-count
+             for title = (gen-name track-words 5)
+             for path = (format nil "~A/~A/~A - ~A/~A.mp3"
+                                (elt (album-artist album) 0) (album-artist album)
+                                (album-year album) (album-album album)
+                                title)
+             for id = (get-file-id (pathname path))
+             for track = (make-track
+                          :album album
+                          :artist (album-artist album)
+                          :no (list (write-to-string (1+ i)) (write-to-string track-count))
+                          :title title
+                          :part-of-set '("1" "1")
+                          :bit-rate bit-rate
+                          :is-vbr is-vbr
+                          :duration (+ 30 (random 300)))
+             do (setf (gethash id tracks)
+                      (make-entry :path path :data track
+                                  :added (get-universal-time) :modified (get-universal-time) :present t))
+             do (incf (album-total-duration album) (track-duration track))))
+    tracks))
+
+(defun generate-dbs (num-tracks dbs)
+  (let* ((albums (generate-albums (round num-tracks 12) (cdr dbs)))
+         (tracks (generate-tracks 24 albums (car dbs))))
+    (cons tracks albums)))