| 1 | ;;;; MPCL -- Common Lisp MPD Client library |
| 2 | |
| 3 | #-sbcl (error "No known socket interface for ~a" (lisp-implementation-type)) |
| 4 | |
| 5 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 6 | (require 'sb-bsd-sockets) |
| 7 | (require 'cl-ppcre)) |
| 8 | (defpackage :mpcl (:use :cl :sb-bsd-sockets)) |
| 9 | (in-package :mpcl) |
| 10 | |
| 11 | ;;; Global variables |
| 12 | (defvar *socket* nil) |
| 13 | (defvar *last-command* 0) |
| 14 | (defvar *last-server* nil) |
| 15 | (defvar *retries* 0) |
| 16 | #+sbcl (defvar *conn-lock* (sb-thread:make-mutex)) |
| 17 | |
| 18 | ;;; Utility functions |
| 19 | (defmacro concat (&rest strings) |
| 20 | `(concatenate 'string ,@strings)) |
| 21 | |
| 22 | (defun assert-type (type val) |
| 23 | (assert (typep val type)) |
| 24 | val) |
| 25 | |
| 26 | (defun clipnum (num min max) |
| 27 | (cond ((< num min) min) |
| 28 | ((> num max) max) |
| 29 | (t num))) |
| 30 | |
| 31 | (defmacro regex-cond (key &body clauses) |
| 32 | (let ((match (gensym)) |
| 33 | (sub (gensym)) |
| 34 | (val (gensym)) |
| 35 | (block-nm (gensym))) |
| 36 | (flet ((ctrans (clause) |
| 37 | (if (eq (first clause) 'otherwise) |
| 38 | `(return-from ,block-nm |
| 39 | (progn ,@(rest clause))) |
| 40 | (destructuring-bind (regex arglist &body body) |
| 41 | clause |
| 42 | `(multiple-value-bind (,match ,sub) |
| 43 | (ppcre:scan-to-strings ,regex ,val) |
| 44 | ,@(if (null arglist) |
| 45 | `((declare (ignore ,sub)))) |
| 46 | (if ,match |
| 47 | (return-from ,block-nm |
| 48 | (let ,(let ((argno 0)) |
| 49 | (mapcar #'(lambda (arg) |
| 50 | (prog1 `(,arg (aref ,sub ,argno)) |
| 51 | (incf argno))) |
| 52 | arglist)) |
| 53 | ,@body)))))))) |
| 54 | `(block ,block-nm |
| 55 | (let ((,val (the string ,key))) |
| 56 | ,@(mapcar #'ctrans clauses)))))) |
| 57 | |
| 58 | ;;; Error conditions |
| 59 | (define-condition protocol-error (error) |
| 60 | ((message :reader protocol-error-message |
| 61 | :initarg :message |
| 62 | :type string) |
| 63 | (real-error :reader protocol-error-cause |
| 64 | :initarg :cause |
| 65 | :type condition |
| 66 | :initform nil) |
| 67 | (retries :reader protocol-error-retries |
| 68 | :initarg :retries |
| 69 | :type integer |
| 70 | :initform 0)) |
| 71 | (:report (lambda (c s) |
| 72 | (if (protocol-error-cause c) |
| 73 | (format s "~A: ~A" (protocol-error-message c) (protocol-error-cause c)) |
| 74 | (format s "Protocol error occurred on mpd socket: ~A" (protocol-error-message c)))))) |
| 75 | |
| 76 | (define-condition protocol-input-error (protocol-error) |
| 77 | ((inputs :reader protocol-error-inputs |
| 78 | :initarg :inputs)) |
| 79 | (:report (lambda (c s) |
| 80 | (apply #'format s (protocol-error-message c) (protocol-error-inputs c))))) |
| 81 | |
| 82 | (define-condition command-error (error) |
| 83 | ((err-code :reader command-error-code |
| 84 | :initarg :err-code |
| 85 | :type integer) |
| 86 | (message :reader command-error-message |
| 87 | :initarg :message |
| 88 | :type string)) |
| 89 | (:report (lambda (c s) |
| 90 | (format s "mpd error response: ~A" (command-error-message c))))) |
| 91 | |
| 92 | (defvar *command-error-types* (make-hash-table)) |
| 93 | |
| 94 | (defmacro def-command-error-type (code name desc) |
| 95 | (let ((cond-sym (intern (concat "COMMAND-ERROR-" (symbol-name name))))) |
| 96 | `(progn (define-condition ,cond-sym (command-error) |
| 97 | () |
| 98 | (:report (lambda (c s) |
| 99 | (format s "mpd error response: ~A (message was: `~A')" ,desc (command-error-message c))))) |
| 100 | (setf (gethash ,code *command-error-types*) ',cond-sym) |
| 101 | (export '(,cond-sym))))) |
| 102 | ;; The following are fetched from libmpdclient.h. In all honesty, I |
| 103 | ;; can't really figure out what they mean just from their names, so |
| 104 | ;; the descriptions aren't optimal in every conceivable way. |
| 105 | (def-command-error-type 1 not-list "not list") |
| 106 | (def-command-error-type 2 arg "argument") |
| 107 | (def-command-error-type 3 password "bad password") |
| 108 | (def-command-error-type 4 permission "permission denied") |
| 109 | (def-command-error-type 5 unknown-cmd "unknown command") |
| 110 | (def-command-error-type 50 no-exist "item does not exist") |
| 111 | (def-command-error-type 51 playlist-max "playlist overload") ; ?! |
| 112 | (def-command-error-type 52 system "system error") |
| 113 | (def-command-error-type 53 playlist-load "could not load playlist") |
| 114 | (def-command-error-type 54 update-already "already updated") ; ?! |
| 115 | (def-command-error-type 55 player-sync "player sync") ; ?! |
| 116 | (def-command-error-type 56 exist "item already exists") |
| 117 | |
| 118 | (export '(protocol-error reconnect command-error |
| 119 | protocol-error-retries command-error-code |
| 120 | command-error-message)) |
| 121 | |
| 122 | ;;; Struct definitions |
| 123 | (defstruct song |
| 124 | (file "" :type string) |
| 125 | (id -1 :type integer) |
| 126 | (pos -1 :type integer) |
| 127 | (length -1 :type integer) |
| 128 | (track -1 :type integer) |
| 129 | artist title album genre composer date) |
| 130 | |
| 131 | (export '(song |
| 132 | song-file song-id song-pos song-length song-track |
| 133 | song-artist song-title song-album song-genre |
| 134 | song-composer song-date)) |
| 135 | |
| 136 | (defstruct status |
| 137 | (volume 0 :type integer) |
| 138 | (playlist-version -1 :type integer) |
| 139 | (num-songs 0 :type integer) |
| 140 | (song -1 :type integer) |
| 141 | (songid -1 :type integer) |
| 142 | (pos -1 :type integer) |
| 143 | (song-len -1 :type integer) |
| 144 | repeat repeat-song random state) |
| 145 | |
| 146 | ;;; Basic protocol management |
| 147 | #+sbcl (defmacro with-conn-lock (&body body) |
| 148 | `(sb-thread:with-recursive-lock (*conn-lock*) ,@body)) |
| 149 | #-sbcl (defmacro with-conn-lock (&body body) |
| 150 | body) |
| 151 | |
| 152 | (defun disconnect () |
| 153 | "Disconnect from MPD." |
| 154 | (with-conn-lock |
| 155 | (let ((sk (prog1 *socket* (setf *socket* nil)))) |
| 156 | (if sk (ignore-errors (close sk)))))) |
| 157 | |
| 158 | (defun connection-error (condition-type &rest condition-args) |
| 159 | (disconnect) |
| 160 | (error (apply #'make-condition condition-type :retries *retries* condition-args))) |
| 161 | |
| 162 | (defun command-error (code message) |
| 163 | (error (funcall #'make-condition (gethash code *command-error-types* 'command-error) |
| 164 | :err-code code |
| 165 | :message message))) |
| 166 | |
| 167 | (defun get-response () |
| 168 | (let ((ret '()) (last nil)) |
| 169 | (loop (let ((line (handler-case |
| 170 | (read-line *socket*) |
| 171 | (error (err) |
| 172 | (connection-error 'protocol-error |
| 173 | :message "Socket read error" |
| 174 | :cause err))))) |
| 175 | (regex-cond line |
| 176 | ("^OK( .*)?$" |
| 177 | () |
| 178 | (return ret)) |
| 179 | ("^ACK \\[(\\d+)@(\\d+)\\] \\{([^\\}]*)\\} (.*)$" |
| 180 | (code list-pos command rest) |
| 181 | (declare (ignore list-pos command)) |
| 182 | (command-error (parse-integer code) rest)) |
| 183 | ("^([^:]+): (.*)$" |
| 184 | (key val) |
| 185 | (let ((new (list (cons (intern (string-upcase key) (find-package 'keyword)) |
| 186 | val)))) |
| 187 | (if last |
| 188 | (setf (cdr last) new last new) |
| 189 | (setf ret new last new)))) |
| 190 | (otherwise |
| 191 | (connection-error 'protocol-input-error |
| 192 | :message "Invalid response from mpd: ~A" |
| 193 | :inputs (list line)))))))) |
| 194 | |
| 195 | (defun default-host () |
| 196 | (block nil |
| 197 | #+sbcl (let ((host (sb-posix:getenv "MPD_HOST"))) |
| 198 | (when host (return host))) |
| 199 | "localhost")) |
| 200 | |
| 201 | (defun default-port () |
| 202 | (block nil |
| 203 | #+sbcl (let ((port (sb-posix:getenv "MPD_PORT"))) |
| 204 | (when port (return (parse-integer port)))) |
| 205 | 6600)) |
| 206 | |
| 207 | (defun connect (&key (host (default-host)) (port (default-port))) |
| 208 | "Connect to a running MPD." |
| 209 | (disconnect) |
| 210 | (with-conn-lock |
| 211 | (setf *socket* (block outer |
| 212 | (let ((last-err nil)) |
| 213 | (dolist (address (host-ent-addresses (get-host-by-name host))) |
| 214 | (handler-case |
| 215 | (let ((sk (make-instance 'inet-socket :type :stream))) |
| 216 | (socket-connect sk address port) |
| 217 | (return-from outer (socket-make-stream sk :input t :output t :buffering :none))) |
| 218 | (error (err) |
| 219 | (setf last-err err) |
| 220 | (warn "mpd connection failure on address ~A: ~A" address err)))) |
| 221 | (if last-err |
| 222 | (error "Could not connect to mpd: ~A" last-err) |
| 223 | (error "Could not connect to mpd: host name `~A' did not resolve to any addreses" host))))) |
| 224 | (setf *last-server* (cons host port)) |
| 225 | (setf *last-command* (get-universal-time)) |
| 226 | (get-response))) |
| 227 | |
| 228 | (defmacro dovector ((var vec) &body body) |
| 229 | (let ((i (gensym))) |
| 230 | `(dotimes (,i (length ,vec)) |
| 231 | (let ((,var (aref ,vec ,i))) |
| 232 | ,@body)))) |
| 233 | |
| 234 | (defmacro with-push-vector ((push-fun type &key (init-length 16)) &body body) |
| 235 | (let ((vec (gensym))) |
| 236 | `(let ((,vec (make-array (list ,init-length) :element-type ',type :adjustable t :fill-pointer 0))) |
| 237 | (flet ((,push-fun (el) |
| 238 | (declare (type ,type el)) |
| 239 | (vector-push-extend el ,vec))) |
| 240 | ,@body) |
| 241 | ,vec))) |
| 242 | |
| 243 | (defun quote-argument (arg) |
| 244 | (declare (type string arg)) |
| 245 | (if (= (length arg) 0) |
| 246 | "\"\"" |
| 247 | (let* ((quote nil) |
| 248 | (res (with-push-vector (add character) |
| 249 | (dovector (elt arg) |
| 250 | (case elt |
| 251 | ((#\space #\tab) |
| 252 | (setf quote t) (add elt)) |
| 253 | ((#\") |
| 254 | (setf quote t) (add #\\) (add #\")) |
| 255 | ((#\newline) |
| 256 | (error "Cannot send strings containing newlines to mpd: ~S" arg)) |
| 257 | (t (add elt))))))) |
| 258 | (if quote |
| 259 | (concat "\"" res "\"") |
| 260 | res)))) |
| 261 | |
| 262 | (defun arg-to-string (arg) |
| 263 | (quote-argument |
| 264 | (typecase arg |
| 265 | (string arg) |
| 266 | (t (write-to-string arg :escape nil))))) |
| 267 | |
| 268 | (defun mpd-command (&rest words) |
| 269 | (with-conn-lock |
| 270 | (let ((*retries* 0)) |
| 271 | (loop |
| 272 | (restart-case |
| 273 | (progn (if (null *socket*) |
| 274 | (connection-error 'protocol-error |
| 275 | :message "Not connected to mpd")) |
| 276 | (handler-case |
| 277 | (progn (write-string (reduce #'(lambda (a b) (concat a " " b)) |
| 278 | (mapcar #'arg-to-string words)) |
| 279 | *socket*) |
| 280 | (terpri *socket*) |
| 281 | (force-output *socket*)) |
| 282 | (error (err) |
| 283 | (connection-error 'protocol-error |
| 284 | :message "Socket write error" |
| 285 | :cause err))) |
| 286 | (setf *last-command* (get-universal-time)) |
| 287 | (return (get-response))) |
| 288 | (reconnect () |
| 289 | :test (lambda (c) (and (typep c 'protocol-error) (not (null *last-server*)))) |
| 290 | :report (lambda (s) |
| 291 | (format s "Reconnect to ~A:~D and try again (~D retries so far)" (car *last-server*) (cdr *last-server*) *retries*)) |
| 292 | (incf *retries*) |
| 293 | (connect :host (car *last-server*) |
| 294 | :port (cdr *last-server*)))))))) |
| 295 | |
| 296 | (export '(connect disconnect)) |
| 297 | |
| 298 | ;;; Slot parsers |
| 299 | ;; These, and the structures themselves, should probably be rewritten |
| 300 | ;; using macros instead. There's a lot of redundancy. |
| 301 | (defun cons-status (info) |
| 302 | (let ((ret (make-status))) |
| 303 | (dolist (line info ret) |
| 304 | (handler-case |
| 305 | (case (car line) |
| 306 | ((:time) |
| 307 | (let ((pos (assert-type '(integer 0 *) (position #\: (cdr line))))) |
| 308 | (setf (status-pos ret) (parse-integer (subseq (cdr line) 0 pos)) |
| 309 | (status-song-len ret) (parse-integer (subseq (cdr line) (1+ pos)))))) |
| 310 | ((:state) (setf (status-state ret) (intern (string-upcase (cdr line)) (find-package 'keyword)))) |
| 311 | ((:repeat) (setf (status-repeat ret) (not (equal (cdr line) "0")))) |
| 312 | ((:repeatsong) (setf (status-repeat-song ret) (not (equal (cdr line) "0")))) |
| 313 | ((:random) (setf (status-random ret) (not (equal (cdr line) "0")))) |
| 314 | ((:volume) (setf (status-volume ret) (parse-integer (cdr line)))) |
| 315 | ((:playlistlength) (setf (status-num-songs ret) (parse-integer (cdr line)))) |
| 316 | ((:song) (setf (status-song ret) (parse-integer (cdr line)))) |
| 317 | ((:songid) (setf (status-songid ret) (parse-integer (cdr line)))) |
| 318 | ((:playlist) (setf (status-playlist-version ret) (parse-integer (cdr line)))) |
| 319 | ;; Ignored: |
| 320 | ((:xfade :bitrate :audio)) |
| 321 | (t (warn "Unknown status slot ~A" (car line)))) |
| 322 | (parse-error () |
| 323 | (warn "Status slot parse error in ~S, slot was ~S" ret line)))))) |
| 324 | |
| 325 | (defun song-list (info) |
| 326 | (let ((ret '()) (cur nil)) |
| 327 | (dolist (line info ret) |
| 328 | (handler-case |
| 329 | (case (car line) |
| 330 | ((:file) |
| 331 | (setf cur (make-song :file (cdr line))) |
| 332 | (setf ret (nconc ret (list cur)))) |
| 333 | ((:time) (setf (song-length cur) (parse-integer (cdr line)))) |
| 334 | ((:id) (setf (song-id cur) (parse-integer (cdr line)))) |
| 335 | ((:pos) (setf (song-pos cur) (parse-integer (cdr line)))) |
| 336 | ((:track) (setf (song-track cur) (parse-integer (cdr line)))) |
| 337 | ((:title) (setf (song-title cur) (cdr line))) |
| 338 | ((:album) (setf (song-album cur) (cdr line))) |
| 339 | ((:artist) (setf (song-artist cur) (cdr line))) |
| 340 | ((:genre) (setf (song-genre cur) (cdr line))) |
| 341 | ((:composer) (setf (song-composer cur) (cdr line))) |
| 342 | ((:date) (setf (song-date cur) (cdr line))) |
| 343 | (t (warn "Unknown song slot ~A" (car line)))) |
| 344 | (parse-error () |
| 345 | (warn "Song slot parse error in ~A, slot was ~A" cur line)))))) |
| 346 | |
| 347 | ;;; Functions for individual commands |
| 348 | (defun status () |
| 349 | "Fetch and return the current status of the MPD as a STATUS structure." |
| 350 | (cons-status (mpd-command "status"))) |
| 351 | |
| 352 | (defmacro with-status (slots &body body) |
| 353 | "Fetch the current status of the MPD, and then run BODY with the |
| 354 | variables in the SLOTS bound to their curresponding status items. |
| 355 | Available slots are: |
| 356 | |
| 357 | STATE (SYMBOL) |
| 358 | The current state of the MPD |
| 359 | Known values are :STOP, :PAUSE and :PLAY |
| 360 | VOLUME (INTEGER 0 100) |
| 361 | Current output volume |
| 362 | PLAYLIST-VERSION (INTEGER 0 *) |
| 363 | Increases by one each time the playlist changes |
| 364 | NUM-SONGS (INTEGER 0 *) |
| 365 | Number of songs in the playlist |
| 366 | SONG (INTEGER 0 NUM-SONGS) |
| 367 | Index, in the playlist, of the currently playing song |
| 368 | SONGID (INTEGER) |
| 369 | ID of the currently playing song |
| 370 | SONG-LEN (INTEGER 0 *) |
| 371 | Length, in seconds, of currently playing song |
| 372 | POS (INTEGER 0 SONG-LEN) |
| 373 | Current time position of the currently playing song, in seconds |
| 374 | REPEAT (NIL or T) |
| 375 | Non-NIL if the MPD is in repeat mode |
| 376 | REPEAT-SONG (NIL or T) |
| 377 | Non-NIL if the MPD is repeating the current song |
| 378 | (not available without patching) |
| 379 | RANDOM (NIL or T) |
| 380 | Non-NIL if the MPD is in random mode" |
| 381 | (let ((status (gensym "STATUS"))) |
| 382 | `(let* ((,status (status)) |
| 383 | ;; This is kinda ugly, but I don't really know any better |
| 384 | ;; way to do it with structs. |
| 385 | ,@(mapcar #'(lambda (slot-sym) |
| 386 | (let ((slot-fun (intern (concat "STATUS-" (symbol-name slot-sym)) |
| 387 | (find-package 'mpcl)))) |
| 388 | `(,slot-sym (,slot-fun ,status)))) |
| 389 | slots)) |
| 390 | ,@body))) |
| 391 | |
| 392 | (defun play-song (song) |
| 393 | "Switch to a new song. SONG can be either an integer, indicating the |
| 394 | position in the playlist of the song to be played, or a SONG structure |
| 395 | instance (as received from the PLAYLIST function, for example), |
| 396 | reflecting the song to be played." |
| 397 | (etypecase song |
| 398 | (song (mpd-command "playid" (song-id song))) |
| 399 | (integer (mpd-command "play" song)))) |
| 400 | |
| 401 | (defun next () |
| 402 | "Go to the next song in the playlist." |
| 403 | (mpd-command "next")) |
| 404 | |
| 405 | (defun prev () |
| 406 | "Go to the previous song in the playlist." |
| 407 | (mpd-command "previous")) |
| 408 | |
| 409 | (defun toggle-pause () |
| 410 | "Toggle between the :PAUSE and :PLAY states. Has no effect if the |
| 411 | MPD is in the :STOP state." |
| 412 | (mpd-command "pause")) |
| 413 | |
| 414 | (defun pause () |
| 415 | "Pause the playback, but only in the :PLAY state." |
| 416 | (if (eq (status-state (status)) :play) |
| 417 | (toggle-pause))) |
| 418 | |
| 419 | (defun ping () |
| 420 | "Ping the MPD, so as to keep connection open." |
| 421 | (mpd-command "ping")) |
| 422 | |
| 423 | (defun maybe-ping () |
| 424 | "Ping the MPD, but only if more than 10 seconds have elapsed since a |
| 425 | command was last sent to it." |
| 426 | (if (and *socket* |
| 427 | (> (- (get-universal-time) *last-command*) 10)) |
| 428 | (progn (ping) t) |
| 429 | nil)) |
| 430 | |
| 431 | (defun stop () |
| 432 | "Stop playback." |
| 433 | (mpd-command "stop")) |
| 434 | |
| 435 | (defun play () |
| 436 | "Start playback of the current song." |
| 437 | (mpd-command "play")) |
| 438 | |
| 439 | (defun current-song () |
| 440 | "Returns a SONG structure instance reflecting the currently playing song." |
| 441 | (first (song-list (mpd-command "currentsong")))) |
| 442 | |
| 443 | (defun song-info (song-num) |
| 444 | "Returns a SONG structure instance describing the song with the |
| 445 | number SONG-NUM in the playlist" |
| 446 | (declare (type (integer 0 *) song-num)) |
| 447 | (first (song-list (mpd-command "playlistinfo" song-num)))) |
| 448 | |
| 449 | (defun playlist () |
| 450 | "Return a list of SONG structure instances, reflecting the songs in |
| 451 | the current playlist." |
| 452 | (song-list (mpd-command "playlistinfo"))) |
| 453 | |
| 454 | (defun search-song (type datum) |
| 455 | "Search the entire song database for songs matching DATUM. TYPE |
| 456 | specifies what data to search among, and can be one of the following |
| 457 | symbols: |
| 458 | |
| 459 | :ARTIST |
| 460 | :ALBUM |
| 461 | :TITLE |
| 462 | :TRACK |
| 463 | :GENRE |
| 464 | :COMPOSER |
| 465 | :PERFORMER |
| 466 | :COMMENT |
| 467 | |
| 468 | This function returns a list of SONG instances describing the search |
| 469 | results, but meaningful information in the ID and POS slots, whether |
| 470 | or not the songs are actually part of the current playlist." |
| 471 | (song-list (mpd-command "search" (string-downcase (symbol-name type)) datum))) |
| 472 | |
| 473 | (defun search-playlist (type datum) |
| 474 | "Works like the SEARCH-SONG function, but limits the search to the |
| 475 | currently loaded playlist, and will return meaningful ID and POS |
| 476 | information. See the documentation for the SEARCH-SONG function for |
| 477 | further information." |
| 478 | (song-list (mpd-command "playlistsearch" (string-downcase (symbol-name type)) datum))) |
| 479 | |
| 480 | (defun seek (sec &optional relative) |
| 481 | "Seek in the currently playing song. If RELATIVE is NIL (the |
| 482 | default), seeks to SEC seconds from the start; otherwise, seeks to SEC |
| 483 | seconds from the current position (may be negative)." |
| 484 | (with-status (songid pos) |
| 485 | (if relative |
| 486 | (setf sec (+ pos sec))) |
| 487 | (mpd-command "seekid" songid sec))) |
| 488 | |
| 489 | (defun set-volume (value &optional relative) |
| 490 | "Tells the MPD to change the audio system volume to VALUE, ranging |
| 491 | from 0 to 100. If RELATIVE is non-NIL, change the current volume by |
| 492 | VALUE (which may be negative) instead." |
| 493 | (mpd-command "setvol" |
| 494 | (clipnum (if relative |
| 495 | (with-status (volume) |
| 496 | (+ volume value)) |
| 497 | value) |
| 498 | 0 100))) |
| 499 | |
| 500 | (export '(current-song song-info playlist status with-status ping maybe-ping |
| 501 | play-song next prev toggle-pause pause play stop seek set-volume |
| 502 | search-song search-playlist)) |
| 503 | (provide :mpcl) |