Commit | Line | Data |
---|---|---|
9d561d5d FT |
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 | ||
5a4158dd FT |
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))) | |
9d561d5d FT |
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) |