Removed generic address resolution until a sane scheme can be found.
[lisp-utils.git] / mpcl.lisp
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       (when sk (handler-case
157                    (close sk)
158                  (error () (close sk :abort t)))))))
159
160 (defun connection-error (condition-type &rest condition-args)
161   (disconnect)
162   (error (apply #'make-condition condition-type :retries *retries* condition-args)))
163
164 (defun command-error (code message)
165   (error (funcall #'make-condition (gethash code *command-error-types* 'command-error)
166                   :err-code code
167                   :message message)))
168
169 (defun get-response ()
170   (let ((ret '()) (last nil))
171     (loop (let ((line (handler-case
172                           (read-line *socket*)
173                         (error (err)
174                           (connection-error 'protocol-error
175                                             :message "Socket read error"
176                                             :cause err)))))
177             (regex-cond line
178               ("^OK( .*)?$"
179                ()
180                (return ret))
181               ("^ACK \\[(\\d+)@(\\d+)\\] \\{([^\\}]*)\\} (.*)$"
182                (code list-pos command rest)
183                (declare (ignore list-pos command))
184                (command-error (parse-integer code) rest))
185               ("^([^:]+): (.*)$"
186                (key val)
187                (let ((new (list (cons (intern (string-upcase key) (find-package 'keyword))
188                                       val))))
189                  (if last
190                      (setf (cdr last) new last new)
191                      (setf ret new last new))))
192               (otherwise
193                (connection-error 'protocol-input-error
194                                  :message "Invalid response from mpd: ~A"
195                                  :inputs (list line))))))))
196
197 (defun default-host ()
198   (block nil
199     #+sbcl (let ((host (sb-posix:getenv "MPD_HOST")))
200              (when host (return host)))
201     "localhost"))
202
203 (defun default-port ()
204   (block nil
205     #+sbcl (let ((port (sb-posix:getenv "MPD_PORT")))
206              (when port (return (parse-integer port))))
207     6600))
208
209 (defun connect (&key (host (default-host)) (port (default-port)))
210   "Connect to a running MPD."
211   (disconnect)
212   (with-conn-lock
213     (setf *socket* (block outer
214                      (let ((last-err nil))
215                        (dolist (address (host-ent-addresses (get-host-by-name host)))
216                          (handler-case
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)))
220                            (error (err)
221                              (setf last-err err)
222                              (warn "mpd connection failure on address ~A: ~A" address err))))
223                        (if last-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))
228     (get-response)))
229
230 (defmacro dovector ((var vec) &body body)
231   (let ((i (gensym)))
232     `(dotimes (,i (length ,vec))
233        (let ((,var (aref ,vec ,i)))
234          ,@body))))
235
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)))
242          ,@body)
243        ,vec)))
244
245 (defun quote-argument (arg)
246   (declare (type string arg))
247   (if (= (length arg) 0)
248       "\"\""
249       (let* ((quote nil)
250              (res (with-push-vector (add character)
251                     (dovector (elt arg)
252                       (case elt
253                         ((#\space #\tab)
254                          (setf quote t) (add elt))
255                         ((#\")
256                          (setf quote t) (add #\\) (add #\"))
257                         ((#\newline)
258                          (error "Cannot send strings containing newlines to mpd: ~S" arg))
259                         (t (add elt)))))))
260         (if quote
261             (concat "\"" res "\"")
262             res))))
263
264 (defun arg-to-string (arg)
265   (quote-argument
266    (typecase arg
267      (string arg)
268      (t (write-to-string arg :escape nil)))))
269
270 (defun mpd-command (&rest words)
271   (with-conn-lock
272     (let ((*retries* 0))
273       (loop
274          (restart-case
275              (progn (if (null *socket*)
276                         (connection-error 'protocol-error
277                                           :message "Not connected to mpd"))
278                     (handler-case
279                         (progn (write-string (reduce #'(lambda (a b) (concat a " " b))
280                                                      (mapcar #'arg-to-string words))
281                                              *socket*)
282                                (terpri *socket*)
283                                (force-output *socket*))
284                       (error (err)
285                         (connection-error 'protocol-error
286                                           :message "Socket write error"
287                                           :cause err)))
288                     (setf *last-command* (get-universal-time))
289                     (return (get-response)))
290            (reconnect ()
291              :test (lambda (c) (and (typep c 'protocol-error) (not (null *last-server*))))
292              :report (lambda (s)
293                        (format s "Reconnect to ~A:~D and try again (~D retries so far)" (car *last-server*) (cdr *last-server*) *retries*))
294              (incf *retries*)
295              (connect :host (car *last-server*)
296                       :port (cdr *last-server*))))))))
297
298 (export '(connect disconnect))
299
300 ;;; Slot parsers
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)
306       (handler-case 
307           (case (car line)
308             ((:time)
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))))
321             ;; Ignored:
322             ((:xfade :bitrate :audio))
323             (t (warn "Unknown status slot ~A" (car line))))
324         (parse-error ()
325           (warn "Status slot parse error in ~S, slot was ~S" ret line))))))
326
327 (defun song-list (info)
328   (let ((ret '()) (cur nil))
329     (dolist (line info ret)
330       (handler-case 
331           (case (car line)
332             ((:file)
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))))
346         (parse-error ()
347           (warn "Song slot parse error in ~A, slot was ~A" cur line))))))
348
349 ;;; Functions for individual commands
350 (defun status ()
351   "Fetch and return the current status of the MPD as a STATUS structure."
352   (cons-status (mpd-command "status")))
353
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.
357 Available slots are:
358
359   STATE (SYMBOL)
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
370   SONGID (INTEGER)
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
376   REPEAT (NIL or T)
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)
381   RANDOM (NIL or T)
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))))
391                       slots))
392        ,@body)))
393
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."
399   (etypecase song
400     (song (mpd-command "playid" (song-id song)))
401     (integer (mpd-command "play" song))))
402
403 (defun next ()
404   "Go to the next song in the playlist."
405   (mpd-command "next"))
406
407 (defun prev ()
408   "Go to the previous song in the playlist."
409   (mpd-command "previous"))
410
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"))
415
416 (defun pause ()
417   "Pause the playback, but only in the :PLAY state."
418   (if (eq (status-state (status)) :play)
419       (toggle-pause)))
420
421 (defun ping ()
422   "Ping the MPD, so as to keep connection open."
423   (mpd-command "ping"))
424
425 (defun maybe-ping ()
426   "Ping the MPD, but only if more than 10 seconds have elapsed since a
427 command was last sent to it."
428   (if (and *socket*
429            (> (- (get-universal-time) *last-command*) 10))
430       (progn (ping) t)
431       nil))
432
433 (defun stop ()
434   "Stop playback."
435   (mpd-command "stop"))
436
437 (defun play ()
438   "Start playback of the current song."
439   (mpd-command "play"))
440
441 (defun current-song ()
442   "Returns a SONG structure instance reflecting the currently playing song."
443   (first (song-list (mpd-command "currentsong"))))
444
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))))
450
451 (defun playlist ()
452   "Return a list of SONG structure instances, reflecting the songs in
453 the current playlist."
454   (song-list (mpd-command "playlistinfo")))
455
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
459 symbols:
460
461   :ARTIST
462   :ALBUM
463   :TITLE
464   :TRACK
465   :GENRE
466   :COMPOSER
467   :PERFORMER
468   :COMMENT
469
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)))
474
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)))
481
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)
487     (if relative
488         (setf sec (+ pos sec)))
489     (mpd-command "seekid" songid sec)))
490
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)
498                               (+ volume value))
499                             value)
500                         0 100)))
501
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))
505 (provide :mpcl)