(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) (declare #.*standard-optimize-settings*) (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" (or (album-type album) "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 &optional (dumper #'to-json)) (declare #.*standard-optimize-settings* (type function dumper)) `(200 (:content-type "application/json") ,(trivial-utf-8:string-to-utf-8-bytes (funcall dumper 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 :junk-allowed t))) (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+ 100) (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 publisher country 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 dumps-category-result (results) (with-output-to-string* (with-array (loop for (cat . count) in results do (write-item (with-object (write-key-value "item" cat) (write-key-value "count" count))))))) (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) (case category (album #'to-json) (t #'dumps-category-result))))) (defun album-tracks (params) (declare #.*standard-optimize-settings*) (200-json (query-tracks (car *db*) :restrictions `((id . ,(getf params :id)))))) (defun file-server (root) (lambda (params) (declare #.*standard-optimize-settings*) (let ((file (probe-file (cl-fad:merge-pathnames-as-file root (car (getf params :splat)))))) (if file (list 200 nil file) +404+)))) (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) (serve-files t) &allow-other-keys) (when serve-files (loop for (path-prefix . url-prefix) in *path-url-mappings* do (myway:connect *mapper* (concatenate 'string url-prefix "*") (file-server path-prefix)))) (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)))