Mercurial > core / lisp/lib/aud/mpd.lisp
changeset 279: |
efc3e9ec02bf |
child: |
d398c7d4433d |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Mon, 15 Apr 2024 22:17:19 -0400 |
permissions: |
-rw-r--r-- |
description: |
random tune-ups, added mpd and net/util.lisp |
1 ;;; aud/mpd.lisp --- MPD Interface for Lisp 3 ;; based on https://github.com/stassats/mpd 7 ;; The original code hasn't been updated in quite some time. Here 8 ;; we've added in some missing slots, fixed a typo, removed the 9 ;; dependency on usocket library and extended the functionality 16 (define-condition mpd-error (error) 17 ((text :initarg :text :reader text 19 (:report (lambda (condition stream) 20 (princ (text condition) stream)))) 22 (macrolet ((define-conditions (names) 25 `(define-condition ,name (mpd-error) ())) 27 (define-conditions (bad-argument incorrect-password 28 not-permitted unknown-command not-exist 29 playlist-size-exceed already-updating exist))) 31 (defparameter *error-ids-alist* 33 (3 . incorrect-password) 37 (51 . playlist-size-exceed) 38 (54 . already-updating) 42 (defparameter *tag-types* 43 '(:artist :album :title :track :name :genre :date 44 :composer :performer :comment :disc :filename :any) 45 "Types of tags for using in `search' and `find'")) 48 `(member ,@*tag-types*)) 52 :initform nil :initarg :file :accessor file) 54 :initform nil :initarg :title :accessor title) 56 :initform nil :initarg :artist :accessor artist) 58 :initform nil :initarg :albumartist :accessor albumartist) 60 :initform nil :initarg :album :accessor album) 62 :initform nil :initarg :genre :accessor genre) 64 :initform nil :initarg :date :accessor date) 66 :initform nil :initarg :performer :accessor performer) 68 :initform nil :initarg :composer :accessor composer) 70 :initform nil :initarg :disc :accessor disc) 72 :initform nil :initarg :track :accessor track-number) 74 :initform nil :initarg :time :accessor duration) 76 :initform nil :initarg :last-modified :accessor last-modified))) 78 (defclass playlist (track) 80 :initform 0 :initarg :pos :accessor position-in-playlist 83 :initform nil :initarg :duration) 84 (format :initform nil :initarg :format) 86 :initform 0 :initarg :id :accessor id 91 :reader volume :initarg :volume :initform nil) 93 :reader repeat :initarg :repeat :initform nil) 95 :reader randomized :initarg :random :initform nil) 97 :reader playlist-version :initarg :playlist :initform nil) 99 :reader playlist-length :initarg :playlistlength :initform nil) 101 :reader xfade :initarg :xfade :initform nil) 103 :reader state :initarg :state :initform nil) 105 :reader partition :initarg :partition :initform nil) 107 :reader audio :initarg :audio :initform nil) 109 :reader bitrate :initarg :bitrate :initform nil) 111 :reader duration :initarg :duration :initform nil) 113 :reader %time :initarg :time :initform nil) 115 :reader songid :initarg :songid :initform nil) 116 (song :reader song :initarg :song :initform nil) 118 :reader nextsongid :initarg :nextsongid :initform nil) 120 :reader nextsong :initarg :nextsong :initform nil) 122 :reader elapsed :initarg :elapsed :initform nil) 124 :reader mixrampdb :initarg :mixrampdb :initform nil) 126 :reader consume :initarg :consume :initform nil) 128 :reader single :initarg :single :initform nil))) 132 :reader artists :initarg :artists :initform nil) 134 :reader albums :initarg :albums :initform nil) 136 :reader songs :initarg :songs :initform nil) 138 :reader uptime :initarg :uptime :initform nil) 140 :reader playtime :initarg :playtime :initform nil) 142 :reader db-playtime :initarg :db_playtime :initform nil) 144 :reader db-update :initarg :db_update :initform nil))) 146 (macrolet ((generate-commands (class names) 148 ,@(mapcar (lambda (name) 149 `(defmethod ,name ((stream socket)) 150 (,name (,class stream)))) 152 (generate-commands status 153 (volume repeat randomized playlist-version playlist-length 154 xfade state audio bitrate duration songid song)) 155 (generate-commands stats 156 (artists albums songs uptime playtime db-playtime db-update))) 158 (defparameter *integer-keys* 159 '(:id :pos :volume :playlist :playlistlength 160 :xfade :song :songid :bitrate :playtime 161 :artists :albums :songs :uptime :db_playtime :db_update 163 "List of keys which values must be integers.") 165 (defparameter *value-processing-functions* 166 '(:time parse-time :state to-keyword 167 :random string-not-zerop :repeat string-not-zerop 168 :outputenabled string-not-zerop)) 170 (defmethod print-object ((object track) stream) 171 (print-unreadable-object (object stream :type t :identity t) 172 (with-slots (artist title album) object 173 (format stream "~A - ~A (~A)" artist title album)))) 176 (defvar *default-host* "localhost") 177 (defvar *default-port* 6600) 179 (defun connect (&key (host *default-host*) (port *default-port*) password) 181 (let ((connection (socket-connect (make-instance 'inet-socket :type :stream) (get-address-by-name host) port))) 182 (prog1 (values connection 183 (read-answer (socket-make-stream connection :input t :output t))) 185 (password connection password))))) 187 (defun read-answer (stream) 188 (loop for line = (read-line stream) 189 until (string= line "OK" :end1 2) 191 when (string= line "ACK" :end1 3) 192 do (throw-error line))) 194 (defun throw-error (text) 195 ;; Error format: `ACK [<error id>@<position>] {<comand name>} <description>' 196 (let* ((error-id (parse-integer text :start 5 :junk-allowed t)) 197 (delimiter (position #\] text)) 198 (condition (cdr (assoc error-id *error-ids-alist*)))) 199 (error condition :text (subseq text (+ delimiter 2))))) 201 (defmacro with-mpd ((var &rest options) &body body) 202 `(let ((,var (connect ,@options))) 207 (defun send-command (connection command) 208 "Send command to MPD." 209 (let ((stream (socket-make-stream connection :input t))) 210 (unless (open-stream-p stream) 211 (error 'mpd-error :text (format nil "The stream ~A is not opened." stream))) 212 (write-line command stream) 213 (finish-output stream) 214 (read-answer stream))) 218 (defun to-keyword (name) 219 (intern (string-upcase name) :keyword)) 221 (defun split-value (string) 222 "Split a string `key: value' into (list :key value)." 223 (let ((column (position #\: string))) 224 (process-value (to-keyword (subseq string 0 column)) 225 (subseq string (+ 2 column))))) 227 (defun split-values (strings) 228 "Transform a list of strings 'key: value' into the plist." 229 (mapcan #'split-value strings)) 231 (defun process-value (key value) 233 (funcall (value-processing-function key) value))) 235 (defun value-processing-function (key) 236 (if (member key *integer-keys*) 238 (getf *value-processing-functions* key #'identity))) 240 (defun parse-time (time) 241 "\"10:20\" -> (10 20); \"10\" -> 10" 242 (multiple-value-bind (first stop) 243 (parse-integer time :junk-allowed t) 244 (if (= stop (length time)) 247 (parse-integer time :start (1+ stop)))))) 249 (defun string-not-zerop (string) 250 (not (string= string "0"))) 252 (defun filter-keys (strings) 253 "Transform a list of strings 'key: value' into a list of values." 254 (mapcar (lambda (entry) 255 (subseq entry (+ 2 (position #\: entry)))) 258 (defun make-class (data type) 259 "Make a new instance of the class playlist with initargs from 260 the list of strings `key: value'." 261 (apply 'make-instance type (split-values data))) 263 (defun parse-list (list &optional class) 264 "Make a list of new instances of the class `class' with initargs from 265 a list of strings `key: value'. Each track is separeted by the `file' key." 267 (flet ((create-track () 269 (list (apply 'make-instance class track))))) 272 (let ((pair (split-value x))) 274 (:file (prog1 (create-track) 276 ((:directory :playlist) 278 (t (nconc track pair) 285 (defun process-string (string) 286 "Check for emtpy strings, and escape strings when needed." 289 (string-trim '(#\Space #\Tab #\Newline) string))) 290 (when (zerop (length string)) 291 (error 'mpd-error :text "Zero length argument.")) 292 (if (position #\Space string) 293 (prin1-to-string string) 298 (defmacro send (&rest commands) 299 "Macro for using inside `defcommand'." 300 `(send-command connection 301 (format nil "~{~A~^ ~}" 302 (remove nil (list ,@commands))))) 304 (defmacro defcommand (name parameters &body body) 305 `(defun ,name (connection ,@parameters) 308 (defmacro defmethod-command (name parameters &body body) 309 `(defmethod ,name (connection ,@parameters) 312 (defmacro check-args (type &rest args) 313 "Check string and integer arguments." 314 (if (or (eq type 'string) 316 (member 'string type))) 319 `((check-type ,arg ,type "a string") 320 (setf ,arg (process-string ,arg)))) 324 `(check-type ,arg ,type)) 328 (defcommand password (password) 330 (check-args string password) 331 (send "password" password)) 333 (defcommand disconnect () 335 (socket-close connection)) 337 (defcommand now-playing () 338 "Return instance of playlist with current song." 339 (let ((track (send "currentsong"))) 341 (make-class track 'playlist)))) 343 (defcommand disable-output (id) 344 (check-args unsigned-byte id) 345 (send "disableoutput" id)) 347 (defcommand enable-output (id) 348 (check-args unsigned-byte id) 349 (send "enableoutput" id)) 356 "Stop MPD in a safe way." 359 (defcommand status () 360 "Return status of MPD." 361 (make-class (send "status") 'status)) 365 (make-class (send "stats") 'stats)) 367 (defcommand outputs () 368 "Return information about all outputs." 369 (split-values (send "outputs"))) 371 (defcommand commands () 372 "Return list of available commands." 373 (filter-keys (send "commands"))) 375 (defcommand not-commands () 376 "Return list of commands to which the current user does not have access." 378 (send "notcommands"))) 383 "Toggle pause / resume playing." 386 (defcommand play (&optional song-number) 387 (check-args (or unsigned-byte null) song-number) 388 "Begin playing the playlist starting from song-number, default is 0." 389 (send "play" song-number)) 396 "Play next track in the playlist." 399 (defcommand previous () 400 "Play previous track in the playlist." 403 (defcommand crossfade (seconds) 404 (check-args unsigned-byte seconds) 405 "Sets crossfading between songs." 406 (send "crossfade" seconds)) 410 (defcommand list-playlist (name) 411 "List files in the playlist `name'" 412 (check-args string name) 413 (filter-keys (send "listplaylist" name))) 415 (defcommand list-playlist-info (name) 416 "List metadata of tracks in the playlist `name'" 417 (check-args string name) 418 (parse-list (send "listplaylistinfo" name) 'playlist)) 421 "Clear the current playlist." 424 (defcommand save-playlist (filename) 425 "Save the current playlist to the file in the playlist directory." 426 (check-args string filename) 427 (send "save" filename)) 429 (defcommand load-playlist (filename) 430 "Load playlist from file." 431 (check-args string filename) 432 (send "load" filename)) 434 (defcommand rename-playlist (name new-name) 436 (check-args string name new-name) 437 (unless (equal name new-name) 438 (send "rename" name new-name))) 440 (defcommand playlist-info (&optional id) 441 "Return content of the current playlist." 442 (check-args (or unsigned-byte null) id) 444 (make-class (send "playlistinfo" id) 'playlist) 445 (parse-list (send "playlistinfo") 'playlist))) 447 (defcommand playlist-changes (version) 448 "Return changed songs currently in the playlist since `version'." 449 (check-args unsigned-byte version) 450 (parse-list (send "plchanges" version) 'playlist)) 452 (defcommand add-to-playlist (name path) 453 "Add `path' to the playlist `name'." 454 (check-args string name path) 455 (send "playlistadd" name path)) 457 (defcommand clear-playlist (name) 458 "Clear playlist `name'." 459 (check-args string name) 460 (send "playlistclear")) 462 (defcommand delete-from-playlist (name song-id) 463 "Delete `song-id' from playlist `name'." 464 (check-args string name) 465 (check-args unsigned-byte song-id) 466 (send "playlistdelete" name song-id)) 468 (defcommand move-in-playlist (name song-id position) 469 "Move `song-id' in playlist `name' to `position'." 470 (check-args string name) 471 (check-args unsigned-byte song-id position) 472 (send "playlistmove" name song-id position)) 474 (defcommand find-in-current-playlist (scope query) 475 "Search for songs in the current playlist with strict matching." 476 (check-args string scope query) 477 (send "playlistfind" scope query)) 479 (defcommand search-in-current-playlist (scope query) 480 "Search case-insensitively with partial matches for songs in the current playlist" 481 (check-args string scope query) 482 (send "playlistsearch" scope query)) 484 (defgeneric add (connection what) 485 (:documentation "Add file or directory to the current playlist.")) 487 (defmethod-command add ((what track)) 488 (add connection (file what))) 490 (defmethod-command add ((what string)) 491 (check-args string what) 494 (defgeneric add-id (connection what) 495 (:documentation "Like add, but returns a id.")) 497 (defmethod-command add-id ((what track)) 498 (add connection (file what))) 500 (defmethod-command add-id ((what string)) 501 (check-args string what) 502 (car (filter-keys (send "addid" what)))) 504 (defcommand move (from to) 505 "Move track from `from' to `to' in the playlist." 506 (check-args unsigned-byte from to) 508 (send "move" from to))) 510 (defgeneric move-id (connection id to) 511 (:documentation "Move track with `id' to `to' in the playlist.")) 513 (defmethod-command move-id ((track playlist) (to integer)) 514 (move-id connection (id track) to)) 516 (defmethod-command move-id ((id integer) (to integer)) 517 (check-args unsigned-byte id to) 518 (send "moveid" id to)) 520 (defcommand swap (first second) 521 "Swap positions of two tracks." 522 (check-args unsigned-byte first second) 523 (unless (= first second) 524 (send "swap" first second))) 526 (defgeneric swap-id (connection first second) 527 (:documentation "Swap positions of two tracks by id.")) 529 (defmethod-command swap-id ((first playlist) (second playlist)) 530 (swap-id connection (id first) (id second))) 532 (defmethod-command swap-id ((first integer) (second integer)) 533 (check-args unsigned-byte first second) 534 (send "swap" first second)) 536 (defcommand delete-track (number) 537 "Delete track from playlist." 538 (check-args unsigned-byte number) 539 (send "delete" number)) 541 (defgeneric delete-id (connection id) 542 (:documentation "Delete track with `id' from playlist.")) 544 (defmethod-command delete-id ((id playlist)) 545 (delete-id connection (id id))) 547 (defmethod-command delete-id ((id integer)) 548 (check-args unsigned-byte id) 549 (send "deleteid" id)) 551 (defcommand shuffle () 552 "Shuffle the current playlist." 557 (defcommand update (&optional path) 558 "Scan directory for music files and add them to the database." 559 (check-args string path) 560 (send "update" path)) 562 (defcommand find-tracks (type what) 563 "Find tracks in the database with a case sensitive, exact match." 564 (check-args tag-type type) 565 (check-args string what) 566 (parse-list (send "find" type what) 'track)) 568 (defcommand list-metadata (metadata-1 &optional metadata-2 search-term) 569 "List all metadata of `metadata-1'. 570 If `metadata-2' & `search-term' are supplied, 571 then list all `metadata-1' in which `metadata-2' has value `search-term'." 572 (check-args (or string null) search-term) 573 (send "list" metadata-1 metadata-2 search-term)) 575 (defcommand search-tracks (type what) 576 "Find tracks in the database with a case sensitive, inexact match." 577 (check-args tag-type type) 578 (check-args string what) 579 (parse-list (send "search" type what) 'track)) 581 (defcommand list-all-info (&optional path) 582 "Lists all information about files in `path' recursively. Default path is /." 583 (parse-list (send "listallinfo" path) 'track)) 585 (defcommand list-all (&optional path) 586 "Lists all files in `path' recursively. Default path is /." 587 (check-args (or string null) path) 588 (filter-keys (send "listall" path))) 590 (defcommand list-info (&optional path) 591 "Show contents of directory." 592 (check-args (or string null) path) 593 (parse-list (send "lsinfo" path) 'track)) 595 (defcommand count-tracks (scope query) 596 "Number of songs and their total playtime matching `query'. 597 Return: (number playtime)." 598 (check-args string query) 599 (filter-keys (send "count" scope query))) 601 (defcommand tag-types () 602 "Get a list of available metadata types." 603 (filter-keys (send "tagtypes"))) 605 (defcommand url-handlers () 606 "Get a list of available URL handlers." 607 (filter-keys (send "urlhandlers"))) 609 (defun (setf volume) (value connection) 610 "Set the volume to the value between 0-100." 611 (check-type value (integer 0 100) "an integer in range 0-100") 612 (send "setvol" value)) 614 (defun (setf randomized) (value connection) 615 "NIL---turn off random mode, non-nil---turn on random mode." 616 (send "random" (if value 1 0))) 618 (defun (setf repeat) (value connection) 619 "NIL---turn off repeat mode, non-nil---turn on repeat mode." 620 (send "repeat" (if value 1 0))) 622 (defcommand seek (song time) 623 "Skip to a specified point in a song on the playlist." 624 (send "seek" song time)) 626 (defgeneric seek-id (connection song time) 627 (:documentation "Skip to a specified point in a song on the playlist.")) 629 (defmethod-command seek-id ((song playlist) (time integer)) 630 (seek-id connection (id song) time)) 632 (defmethod-command seek-id ((song integer) (time integer)) 633 (check-args unsigned-byte song time) 634 (send "seekid" song time))