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       (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 connect (&key (host "localhost") (port 6600))
 196   "Connect to a running MPD."
 197   (disconnect)
 198   (with-conn-lock
 199     (setf *socket* (block outer
 200                      (let ((last-err nil))
 201                        (dolist (address (host-ent-addresses (get-host-by-name host)))
 202                          (handler-case
 203                              (let ((sk (make-instance 'inet-socket :type :stream)))
 204                                (socket-connect sk address port)
 205                                (return-from outer (socket-make-stream sk :input t :output t :buffering :none)))
 206                            (error (err)
 207                              (setf last-err err)
 208                              (warn "mpd connection failure on address ~A: ~A" address err))))
 209                        (if last-err
 210                            (error "Could not connect to mpd: ~A" last-err)
 211                            (error "Could not connect to mpd: host name `~A' did not resolve to any addreses" host)))))
 212     (setf *last-server* (cons host port))
 213     (setf *last-command* (get-universal-time))
 214     (get-response)))
 215
 216 (defmacro dovector ((var vec) &body body)
 217   (let ((i (gensym)))
 218     `(dotimes (,i (length ,vec))
 219        (let ((,var (aref ,vec ,i)))
 220          ,@body))))
 221
 222 (defmacro with-push-vector ((push-fun type &key (init-length 16)) &body body)
 223   (let ((vec (gensym)))
 224     `(let ((,vec (make-array (list ,init-length) :element-type ',type :adjustable t :fill-pointer 0)))
 225        (flet ((,push-fun (el)
 226                 (declare (type ,type el))
 227                 (vector-push-extend el ,vec)))
 228          ,@body)
 229        ,vec)))
 230
 231 (defun quote-argument (arg)
 232   (declare (type string arg))
 233   (if (= (length arg) 0)
 234       "\"\""
 235       (let* ((quote nil)
 236              (res (with-push-vector (add character)
 237                     (dovector (elt arg)
 238                       (case elt
 239                         ((#\space #\tab)
 240                          (setf quote t) (add elt))
 241                         ((#\")
 242                          (setf quote t) (add #\\) (add #\"))
 243                         ((#\newline)
 244                          (error "Cannot send strings containing newlines to mpd: ~S" arg))
 245                         (t (add elt)))))))
 246         (if quote
 247             (concat "\"" res "\"")
 248             res))))
 249
 250 (defun arg-to-string (arg)
 251   (quote-argument
 252    (typecase arg
 253      (string arg)
 254      (t (write-to-string arg :escape nil)))))
 255
 256 (defun mpd-command (&rest words)
 257   (with-conn-lock
 258     (let ((*retries* 0))
 259       (loop
 260          (restart-case
 261              (progn (if (null *socket*)
 262                         (connection-error 'protocol-error
 263                                           :message "Not connected to mpd"))
 264                     (handler-case
 265                         (progn (write-string (reduce #'(lambda (a b) (concat a " " b))
 266                                                      (mapcar #'arg-to-string words))
 267                                              *socket*)
 268                                (terpri *socket*)
 269                                (force-output *socket*))
 270                       (error (err)
 271                         (connection-error 'protocol-error
 272                                           :message "Socket write error"
 273                                           :cause err)))
 274                     (setf *last-command* (get-universal-time))
 275                     (return (get-response)))
 276            (reconnect ()
 277              :test (lambda (c) (and (typep c 'protocol-error) (not (null *last-server*))))
 278              :report (lambda (s)
 279                        (format s "Reconnect to ~A:~D and try again (~D retries so far)" (car *last-server*) (cdr *last-server*) *retries*))
 280              (incf *retries*)
 281              (connect :host (car *last-server*)
 282                       :port (cdr *last-server*))))))))
 283
 284 (export '(connect disconnect))
 285
 286 ;;; Slot parsers
 287 ;; These, and the structures themselves, should probably be rewritten
 288 ;; using macros instead. There's a lot of redundancy.
 289 (defun cons-status (info)
 290   (let ((ret (make-status)))
 291     (dolist (line info ret)
 292       (handler-case
 293           (case (car line)
 294             ((:time)
 295              (let ((pos (assert-type '(integer 0 *) (position #\: (cdr line)))))
 296                (setf (status-pos ret) (parse-integer (subseq (cdr line) 0 pos))
 297                      (status-song-len ret) (parse-integer (subseq (cdr line) (1+ pos))))))
 298             ((:state) (setf (status-state ret) (intern (string-upcase (cdr line)) (find-package 'keyword))))
 299             ((:repeat) (setf (status-repeat ret) (not (equal (cdr line) "0"))))
 300             ((:repeatsong) (setf (status-repeat-song ret) (not (equal (cdr line) "0"))))
 301             ((:random) (setf (status-random ret) (not (equal (cdr line) "0"))))
 302             ((:volume) (setf (status-volume ret) (parse-integer (cdr line))))
 303             ((:playlistlength) (setf (status-num-songs ret) (parse-integer (cdr line))))
 304             ((:song) (setf (status-song ret) (parse-integer (cdr line))))
 305             ((:songid) (setf (status-songid ret) (parse-integer (cdr line))))
 306             ((:playlist) (setf (status-playlist-version ret) (parse-integer (cdr line))))
 307             ;; Ignored:
 308             ((:xfade :bitrate :audio))
 309             (t (warn "Unknown status slot ~A" (car line))))
 310         (parse-error ()
 311           (warn "Status slot parse error in ~S, slot was ~S" ret line))))))
 312
 313 (defun song-list (info)
 314   (let ((ret '()) (cur nil))
 315     (dolist (line info ret)
 316       (handler-case
 317           (case (car line)
 318             ((:file)
 319              (setf cur (make-song :file (cdr line)))
 320              (setf ret (nconc ret (list cur))))
 321             ((:time) (setf (song-length cur) (parse-integer (cdr line))))
 322             ((:id) (setf (song-id cur) (parse-integer (cdr line))))
 323             ((:pos) (setf (song-pos cur) (parse-integer (cdr line))))
 324             ((:track) (setf (song-track cur) (parse-integer (cdr line))))
 325             ((:title) (setf (song-title cur) (cdr line)))
 326             ((:album) (setf (song-album cur) (cdr line)))
 327             ((:artist) (setf (song-artist cur) (cdr line)))
 328             ((:genre) (setf (song-genre cur) (cdr line)))
 329             ((:composer) (setf (song-composer cur) (cdr line)))
 330             ((:date) (setf (song-date cur) (cdr line)))
 331             (t (warn "Unknown song slot ~A" (car line))))
 332         (parse-error ()
 333           (warn "Song slot parse error in ~A, slot was ~A" cur line))))))
 334
 335 ;;; Functions for individual commands
 336 (defun status ()
 337   "Fetch and return the current status of the MPD as a STATUS structure."
 338   (cons-status (mpd-command "status")))
 339
 340 (defmacro with-status (slots &body body)
 341   "Fetch the current status of the MPD, and then run BODY with the
 342 variables in the SLOTS bound to their curresponding status items.
 343 Available slots are:
 344
 345   STATE (SYMBOL)
 346     The current state of the MPD
 347     Known values are :STOP, :PAUSE and :PLAY
 348   VOLUME (INTEGER 0 100)
 349     Current output volume
 350   PLAYLIST-VERSION (INTEGER 0 *)
 351     Increases by one each time the playlist changes
 352   NUM-SONGS (INTEGER 0 *)
 353     Number of songs in the playlist
 354   SONG (INTEGER 0 NUM-SONGS)
 355     Index, in the playlist, of the currently playing song
 356   SONGID (INTEGER)
 357     ID of the currently playing song
 358   SONG-LEN (INTEGER 0 *)
 359     Length, in seconds, of currently playing song
 360   POS (INTEGER 0 SONG-LEN)
 361     Current time position of the currently playing song, in seconds
 362   REPEAT (NIL or T)
 363     Non-NIL if the MPD is in repeat mode
 364   REPEAT-SONG (NIL or T)
 365     Non-NIL if the MPD is repeating the current song
 366     (not available without patching)
 367   RANDOM (NIL or T)
 368     Non-NIL if the MPD is in random mode"
 369   (let ((status (gensym "STATUS")))
 370     `(let* ((,status (status))
 371             ;; This is kinda ugly, but I don't really know any better
 372             ;; way to do it with structs.
 373             ,@(mapcar #'(lambda (slot-sym)
 374                           (let ((slot-fun (intern (concat "STATUS-" (symbol-name slot-sym))
 375                                                   (find-package 'mpcl))))
 376                             `(,slot-sym (,slot-fun ,status))))
 377                       slots))
 378        ,@body)))
 379
 380 (defun play-song (song)
 381   "Switch to a new song. SONG can be either an integer, indicating the
 382 position in the playlist of the song to be played, or a SONG structure
 383 instance (as received from the PLAYLIST function, for example),
 384 reflecting the song to be played."
 385   (etypecase song
 386     (song (mpd-command "playid" (song-id song)))
 387     (integer (mpd-command "play" song))))
 388
 389 (defun next ()
 390   "Go to the next song in the playlist."
 391   (mpd-command "next"))
 392
 393 (defun prev ()
 394   "Go to the previous song in the playlist."
 395   (mpd-command "previous"))
 396
 397 (defun toggle-pause ()
 398   "Toggle between the :PAUSE and :PLAY states. Has no effect if the
 399 MPD is in the :STOP state."
 400   (mpd-command "pause"))
 401
 402 (defun pause ()
 403   "Pause the playback, but only in the :PLAY state."
 404   (if (eq (status-state (status)) :play)
 405       (toggle-pause)))
 406
 407 (defun ping ()
 408   "Ping the MPD, so as to keep connection open."
 409   (mpd-command "ping"))
 410
 411 (defun maybe-ping ()
 412   "Ping the MPD, but only if more than 10 seconds have elapsed since a
 413 command was last sent to it."
 414   (if (and *socket*
 415            (> (- (get-universal-time) *last-command*) 10))
 416       (progn (ping) t)
 417       nil))
 418
 419 (defun stop ()
 420   "Stop playback."
 421   (mpd-command "stop"))
 422
 423 (defun play ()
 424   "Start playback of the current song."
 425   (mpd-command "play"))
 426
 427 (defun current-song ()
 428   "Returns a SONG structure instance reflecting the currently playing song."
 429   (first (song-list (mpd-command "currentsong"))))
 430
 431 (defun song-info (song-num)
 432   "Returns a SONG structure instance describing the song with the
 433 number SONG-NUM in the playlist"
 434   (declare (type (integer 0 *) song-num))
 435   (first (song-list (mpd-command "playlistinfo" song-num))))
 436
 437 (defun playlist ()
 438   "Return a list of SONG structure instances, reflecting the songs in
 439 the current playlist."
 440   (song-list (mpd-command "playlistinfo")))
 441
 442 (defun search-song (type datum)
 443   "Search the entire song database for songs matching DATUM. TYPE
 444 specifies what data to search among, and can be one of the following
 445 symbols:
 446
 447   :ARTIST
 448   :ALBUM
 449   :TITLE
 450   :TRACK
 451   :GENRE
 452   :COMPOSER
 453   :PERFORMER
 454   :COMMENT
 455
 456 This function returns a list of SONG instances describing the search
 457 results, but meaningful information in the ID and POS slots, whether
 458 or not the songs are actually part of the current playlist."
 459   (song-list (mpd-command "search" (string-downcase (symbol-name type)) datum)))
 460
 461 (defun search-playlist (type datum)
 462   "Works like the SEARCH-SONG function, but limits the search to the
 463 currently loaded playlist, and will return meaningful ID and POS
 464 information. See the documentation for the SEARCH-SONG function for
 465 further information."
 466   (song-list (mpd-command "playlistsearch" (string-downcase (symbol-name type)) datum)))
 467
 468 (defun seek (sec &optional relative)
 469   "Seek in the currently playing song. If RELATIVE is NIL (the
 470 default), seeks to SEC seconds from the start; otherwise, seeks to SEC
 471 seconds from the current position (may be negative)."
 472   (with-status (songid pos)
 473     (if relative
 474         (setf sec (+ pos sec)))
 475     (mpd-command "seekid" songid sec)))
 476
 477 (defun set-volume (value &optional relative)
 478   "Tells the MPD to change the audio system volume to VALUE, ranging
 479 from 0 to 100. If RELATIVE is non-NIL, change the current volume by
 480 VALUE (which may be negative) instead."
 481   (mpd-command "setvol"
 482                (clipnum (if relative
 483                             (with-status (volume)
 484                               (+ volume value))
 485                             value)
 486                         0 100)))
 487
 488 (export '(current-song song-info playlist status with-status ping maybe-ping
 489           play-song next prev toggle-pause pause play stop seek set-volume
 490           search-song search-playlist))
 491 (provide :mpcl)