1 ;;;; MPCL -- Common Lisp MPD Client library
3 #-sbcl (error "No known socket interface for ~a" (lisp-implementation-type))
5 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (require 'sb-bsd-sockets)
8 (defpackage :mpcl (:use :cl :sb-bsd-sockets))
13 (defvar *last-command* 0)
14 (defvar *last-server* nil)
16 #+sbcl (defvar *conn-lock* (sb-thread:make-mutex))
19 (defmacro concat (&rest strings)
20 `(concatenate 'string ,@strings))
22 (defun assert-type (type val)
23 (assert (typep val type))
26 (defun clipnum (num min max)
27 (cond ((< num min) min)
31 (defmacro regex-cond (key &body clauses)
32 (let ((match (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)
42 `(multiple-value-bind (,match ,sub)
43 (ppcre:scan-to-strings ,regex ,val)
45 `((declare (ignore ,sub))))
47 (return-from ,block-nm
48 (let ,(let ((argno 0))
49 (mapcar #'(lambda (arg)
50 (prog1 `(,arg (aref ,sub ,argno))
55 (let ((,val (the string ,key)))
56 ,@(mapcar #'ctrans clauses))))))
59 (define-condition protocol-error (error)
60 ((message :reader protocol-error-message
63 (real-error :reader protocol-error-cause
67 (retries :reader protocol-error-retries
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))))))
76 (define-condition protocol-input-error (protocol-error)
77 ((inputs :reader protocol-error-inputs
79 (:report (lambda (c s)
80 (apply #'format s (protocol-error-message c) (protocol-error-inputs c)))))
82 (define-condition command-error (error)
83 ((err-code :reader command-error-code
86 (message :reader command-error-message
89 (:report (lambda (c s)
90 (format s "mpd error response: ~A" (command-error-message c)))))
92 (defvar *command-error-types* (make-hash-table))
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)
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")
118 (export '(protocol-error reconnect command-error
119 protocol-error-retries command-error-code
120 command-error-message))
122 ;;; Struct definitions
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)
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))
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)
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)
153 "Disconnect from MPD."
155 (let ((sk (prog1 *socket* (setf *socket* nil))))
156 (when sk (handler-case
158 (error () (close sk :abort t)))))))
160 (defun connection-error (condition-type &rest condition-args)
162 (error (apply #'make-condition condition-type :retries *retries* condition-args)))
164 (defun command-error (code message)
165 (error (funcall #'make-condition (gethash code *command-error-types* 'command-error)
169 (defun get-response ()
170 (let ((ret '()) (last nil))
171 (loop (let ((line (handler-case
174 (connection-error 'protocol-error
175 :message "Socket read error"
181 ("^ACK \\[(\\d+)@(\\d+)\\] \\{([^\\}]*)\\} (.*)$"
182 (code list-pos command rest)
183 (declare (ignore list-pos command))
184 (command-error (parse-integer code) rest))
187 (let ((new (list (cons (intern (string-upcase key) (find-package 'keyword))
190 (setf (cdr last) new last new)
191 (setf ret new last new))))
193 (connection-error 'protocol-input-error
194 :message "Invalid response from mpd: ~A"
195 :inputs (list line))))))))
197 (defun default-host ()
199 #+sbcl (let ((host (sb-posix:getenv "MPD_HOST")))
200 (when host (return host)))
203 (defun default-port ()
205 #+sbcl (let ((port (sb-posix:getenv "MPD_PORT")))
206 (when port (return (parse-integer port))))
209 (defun connect (&key (host (default-host)) (port (default-port)))
210 "Connect to a running MPD."
213 (setf *socket* (block outer
214 (let ((last-err nil))
215 (dolist (address (host-ent-addresses (get-host-by-name host)))
217 (let ((sk (make-instance 'inet-socket :type :stream)))
218 (socket-connect sk address port)
219 (return-from outer (socket-make-stream sk :input t :output t :buffering :none)))
222 (warn "mpd connection failure on address ~A: ~A" address err))))
224 (error "Could not connect to mpd: ~A" last-err)
225 (error "Could not connect to mpd: host name `~A' did not resolve to any addreses" host)))))
226 (setf *last-server* (cons host port))
227 (setf *last-command* (get-universal-time))
230 (defmacro dovector ((var vec) &body body)
232 `(dotimes (,i (length ,vec))
233 (let ((,var (aref ,vec ,i)))
236 (defmacro with-push-vector ((push-fun type &key (init-length 16)) &body body)
237 (let ((vec (gensym)))
238 `(let ((,vec (make-array (list ,init-length) :element-type ',type :adjustable t :fill-pointer 0)))
239 (flet ((,push-fun (el)
240 (declare (type ,type el))
241 (vector-push-extend el ,vec)))
245 (defun quote-argument (arg)
246 (declare (type string arg))
247 (if (= (length arg) 0)
250 (res (with-push-vector (add character)
254 (setf quote t) (add elt))
256 (setf quote t) (add #\\) (add #\"))
258 (error "Cannot send strings containing newlines to mpd: ~S" arg))
261 (concat "\"" res "\"")
264 (defun arg-to-string (arg)
268 (t (write-to-string arg :escape nil)))))
270 (defun mpd-command (&rest words)
275 (progn (if (null *socket*)
276 (connection-error 'protocol-error
277 :message "Not connected to mpd"))
279 (progn (write-string (reduce #'(lambda (a b) (concat a " " b))
280 (mapcar #'arg-to-string words))
283 (force-output *socket*))
285 (connection-error 'protocol-error
286 :message "Socket write error"
288 (setf *last-command* (get-universal-time))
289 (return (get-response)))
291 :test (lambda (c) (and (typep c 'protocol-error) (not (null *last-server*))))
293 (format s "Reconnect to ~A:~D and try again (~D retries so far)" (car *last-server*) (cdr *last-server*) *retries*))
295 (connect :host (car *last-server*)
296 :port (cdr *last-server*))))))))
298 (export '(connect disconnect))
301 ;; These, and the structures themselves, should probably be rewritten
302 ;; using macros instead. There's a lot of redundancy.
303 (defun cons-status (info)
304 (let ((ret (make-status)))
305 (dolist (line info ret)
309 (let ((pos (assert-type '(integer 0 *) (position #\: (cdr line)))))
310 (setf (status-pos ret) (parse-integer (subseq (cdr line) 0 pos))
311 (status-song-len ret) (parse-integer (subseq (cdr line) (1+ pos))))))
312 ((:state) (setf (status-state ret) (intern (string-upcase (cdr line)) (find-package 'keyword))))
313 ((:repeat) (setf (status-repeat ret) (not (equal (cdr line) "0"))))
314 ((:repeatsong) (setf (status-repeat-song ret) (not (equal (cdr line) "0"))))
315 ((:random) (setf (status-random ret) (not (equal (cdr line) "0"))))
316 ((:volume) (setf (status-volume ret) (parse-integer (cdr line))))
317 ((:playlistlength) (setf (status-num-songs ret) (parse-integer (cdr line))))
318 ((:song) (setf (status-song ret) (parse-integer (cdr line))))
319 ((:songid) (setf (status-songid ret) (parse-integer (cdr line))))
320 ((:playlist) (setf (status-playlist-version ret) (parse-integer (cdr line))))
322 ((:xfade :bitrate :audio))
323 (t (warn "Unknown status slot ~A" (car line))))
325 (warn "Status slot parse error in ~S, slot was ~S" ret line))))))
327 (defun song-list (info)
328 (let ((ret '()) (cur nil))
329 (dolist (line info ret)
333 (setf cur (make-song :file (cdr line)))
334 (setf ret (nconc ret (list cur))))
335 ((:time) (setf (song-length cur) (parse-integer (cdr line))))
336 ((:id) (setf (song-id cur) (parse-integer (cdr line))))
337 ((:pos) (setf (song-pos cur) (parse-integer (cdr line))))
338 ((:track) (setf (song-track cur) (parse-integer (cdr line))))
339 ((:title) (setf (song-title cur) (cdr line)))
340 ((:album) (setf (song-album cur) (cdr line)))
341 ((:artist) (setf (song-artist cur) (cdr line)))
342 ((:genre) (setf (song-genre cur) (cdr line)))
343 ((:composer) (setf (song-composer cur) (cdr line)))
344 ((:date) (setf (song-date cur) (cdr line)))
345 (t (warn "Unknown song slot ~A" (car line))))
347 (warn "Song slot parse error in ~A, slot was ~A" cur line))))))
349 ;;; Functions for individual commands
351 "Fetch and return the current status of the MPD as a STATUS structure."
352 (cons-status (mpd-command "status")))
354 (defmacro with-status (slots &body body)
355 "Fetch the current status of the MPD, and then run BODY with the
356 variables in the SLOTS bound to their curresponding status items.
360 The current state of the MPD
361 Known values are :STOP, :PAUSE and :PLAY
362 VOLUME (INTEGER 0 100)
363 Current output volume
364 PLAYLIST-VERSION (INTEGER 0 *)
365 Increases by one each time the playlist changes
366 NUM-SONGS (INTEGER 0 *)
367 Number of songs in the playlist
368 SONG (INTEGER 0 NUM-SONGS)
369 Index, in the playlist, of the currently playing song
371 ID of the currently playing song
372 SONG-LEN (INTEGER 0 *)
373 Length, in seconds, of currently playing song
374 POS (INTEGER 0 SONG-LEN)
375 Current time position of the currently playing song, in seconds
377 Non-NIL if the MPD is in repeat mode
378 REPEAT-SONG (NIL or T)
379 Non-NIL if the MPD is repeating the current song
380 (not available without patching)
382 Non-NIL if the MPD is in random mode"
383 (let ((status (gensym "STATUS")))
384 `(let* ((,status (status))
385 ;; This is kinda ugly, but I don't really know any better
386 ;; way to do it with structs.
387 ,@(mapcar #'(lambda (slot-sym)
388 (let ((slot-fun (intern (concat "STATUS-" (symbol-name slot-sym))
389 (find-package 'mpcl))))
390 `(,slot-sym (,slot-fun ,status))))
394 (defun play-song (song)
395 "Switch to a new song. SONG can be either an integer, indicating the
396 position in the playlist of the song to be played, or a SONG structure
397 instance (as received from the PLAYLIST function, for example),
398 reflecting the song to be played."
400 (song (mpd-command "playid" (song-id song)))
401 (integer (mpd-command "play" song))))
404 "Go to the next song in the playlist."
405 (mpd-command "next"))
408 "Go to the previous song in the playlist."
409 (mpd-command "previous"))
411 (defun toggle-pause ()
412 "Toggle between the :PAUSE and :PLAY states. Has no effect if the
413 MPD is in the :STOP state."
414 (mpd-command "pause"))
417 "Pause the playback, but only in the :PLAY state."
418 (if (eq (status-state (status)) :play)
422 "Ping the MPD, so as to keep connection open."
423 (mpd-command "ping"))
426 "Ping the MPD, but only if more than 10 seconds have elapsed since a
427 command was last sent to it."
429 (> (- (get-universal-time) *last-command*) 10))
435 (mpd-command "stop"))
438 "Start playback of the current song."
439 (mpd-command "play"))
441 (defun current-song ()
442 "Returns a SONG structure instance reflecting the currently playing song."
443 (first (song-list (mpd-command "currentsong"))))
445 (defun song-info (song-num)
446 "Returns a SONG structure instance describing the song with the
447 number SONG-NUM in the playlist"
448 (declare (type (integer 0 *) song-num))
449 (first (song-list (mpd-command "playlistinfo" song-num))))
452 "Return a list of SONG structure instances, reflecting the songs in
453 the current playlist."
454 (song-list (mpd-command "playlistinfo")))
456 (defun search-song (type datum)
457 "Search the entire song database for songs matching DATUM. TYPE
458 specifies what data to search among, and can be one of the following
470 This function returns a list of SONG instances describing the search
471 results, but meaningful information in the ID and POS slots, whether
472 or not the songs are actually part of the current playlist."
473 (song-list (mpd-command "search" (string-downcase (symbol-name type)) datum)))
475 (defun search-playlist (type datum)
476 "Works like the SEARCH-SONG function, but limits the search to the
477 currently loaded playlist, and will return meaningful ID and POS
478 information. See the documentation for the SEARCH-SONG function for
479 further information."
480 (song-list (mpd-command "playlistsearch" (string-downcase (symbol-name type)) datum)))
482 (defun seek (sec &optional relative)
483 "Seek in the currently playing song. If RELATIVE is NIL (the
484 default), seeks to SEC seconds from the start; otherwise, seeks to SEC
485 seconds from the current position (may be negative)."
486 (with-status (songid pos)
488 (setf sec (+ pos sec)))
489 (mpd-command "seekid" songid sec)))
491 (defun set-volume (value &optional relative)
492 "Tells the MPD to change the audio system volume to VALUE, ranging
493 from 0 to 100. If RELATIVE is non-NIL, change the current volume by
494 VALUE (which may be negative) instead."
495 (mpd-command "setvol"
496 (clipnum (if relative
497 (with-status (volume)
502 (export '(current-song song-info playlist status with-status ping maybe-ping
503 play-song next prev toggle-pause pause play stop seek set-volume
504 search-song search-playlist))