chad-music/server.lisp

(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
                                                  (format nil "~{~A~^/~}"
                                                          (mapcar #'quri:url-encode
                                                                  (split-sequence:split-sequence #\/ suffix)))))))))))

(defmacro maybe-key-value (key value)
  `(when ,value
     (write-key-value ,key ,value)))

(defmethod %to-json ((album album))
  (with-object
    (maybe-key-value "id" (album-id album))
    (maybe-key-value "artist" (album-artist album))
    (maybe-key-value "year" (album-year album))
    (maybe-key-value "album" (album-album album))
    (maybe-key-value "original_date" (album-original-date album))
    (maybe-key-value "publisher" (album-publisher album))
    (maybe-key-value "country" (album-country album))
    (maybe-key-value "genre" (album-genre album))
    (maybe-key-value "type" (album-type album))
    (maybe-key-value "status" (album-status album))
    (maybe-key-value "mb_id" (album-mb-id album))
    (maybe-key-value "track_count" (album-track-count album))
    (maybe-key-value "total_duration" (album-total-duration album))
    (maybe-key-value "cover" (get-url (album-cover album)))))

(defmethod %to-json ((track track))
  (with-object
    (maybe-key-value "artist" (track-artist track))
    (maybe-key-value "album" (album-album (track-album track)))
    (maybe-key-value "no" (clear-track-no (track-no track)))
    (maybe-key-value "title" (track-title track))
    (maybe-key-value "bit_rate" (track-bit-rate track))
    (maybe-key-value "vbr" (if (track-is-vbr track) :true :false))
    (maybe-key-value "duration" (track-duration track))
    (maybe-key-value "url" (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" "publisher" "country" "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 publisher country 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)))