new file mode 100644

@@ -0,0 +1,3 @@

+*\~

+\#*\#

+'

new file mode 100644

@@ -0,0 +1 @@

+This is the stub README.txt for the "mpd-remote" project.

new file mode 100644

@@ -0,0 +1,17 @@

+;;;; mpd-remote.asd

+

+(asdf:defsystem #:mpd-remote

+  :description "Describe mpd-remote here"

+  :author "Your Name <your.name@example.com>"

+  :license "Specify license here"

+  :depends-on (#:fwoar.lisputils

+               #:alexandria

+	       #:serapeum

+	       #:flexi-streams

+	       #:usocket)

+               

+  :serial t

+  :components ((:file "package")

+               (:file "song-handling")

+               (:file "mpd-remote")))

+

new file mode 100644

@@ -0,0 +1,86 @@

+;;;; mpd-remote.lisp

+

+(in-package #:mpd-remote)

+

+;;; "mpd-remote" goes here. Hacks and glory await!

+

+(defun call-with-mpd-connection (host port cb)

+  (usocket:with-client-socket (sock stream host port :element-type '(unsigned-byte 8))

+    (let ((stream (flexi-streams:make-flexi-stream stream :external-format :utf8)))

+      (assert (alexandria:starts-with-subseq "OK" (read-line stream)))

+      (funcall cb sock stream))))

+

+(define-condition mpd-error ()

+  ((message :initarg :message :reader message))

+  (:report (lambda (condition stream)

+	     (format stream "~a" (message condition)))))

+

+(defmacro do-until ((end-condition &optional result) &body body)

+  `(do () (,end-condition ,@(when result `(,result)))

+     ,@body))

+

+(defun get-response (stream)

+  (let ((result (list))

+	(done nil))

+      (do-until (done (nreverse result))

+	(let ((line (read-line stream)))

+	  (format t "~&~s~%" line)

+	  (if (string= line "OK")

+	      (setf done t)

+	      (multiple-value-bind (error-p suffix) (alexandria:starts-with-subseq "ACK" line :return-suffix t)

+		(if error-p

+		    (error 'mpd-error :message (serapeum:trim-whitespace suffix))

+		    (push line result))))))))

+

+(defmacro with-mpd-connection ((socket-sym stream-sym &optional (host "127.0.0.1") (port 6600)) &body body)

+  `(call-with-mpd-connection ,host ,port

+			     (lambda (,socket-sym ,stream-sym)

+			       ,@body)))

+

+(defclass mpd-command ()

+  ())

+

+(defgeneric render-mpd-command (command args))

+

+(defgeneric send-command (stream command &key)

+  (:method (stream command &rest r &key)

+    (write-line (render-mpd-command command

+				    r)

+		stream)

+    (finish-output stream)

+    (get-response stream)))

+

+(defclass current-song (mpd-command)

+  ())

+

+(defmacro mpd-progn ((stream) &body body)

+  `(let ((*standard-output* ,stream))

+     (write-line "command_list_ok_begin")

+     (unwind-protect (progn ,@body)

+       (write-line "command_list_end"))))

+

+(defmethod render-mpd-command ((command (eql :current-song)) args)

+  (declare (ignore command args))

+  "currentsong")

+

+(defmethod send-command :around (stream (command (eql :current-song)) &key)

+  (declare (ignore stream))

+  (mpd-remote.song:parse-song (call-next-method)))

+

+(defmethod render-mpd-command ((command (eql :playlist-info)) args)

+  (declare (ignore command))

+  (format nil "playlistinfo ~{~a~^:~}" (getf args :slice)))

+

+(defmethod send-command :around (stream (command (eql :playlist-info)) &key slice)

+  (declare (ignore command stream))

+  (mapcar #'mpd-remote.song:parse-song

+	  (mpd-remote.song:split-songs (call-next-method))))

+

+(defmethod render-mpd-command ((command (eql :play)) args)

+  (declare (ignore command))

+  "play")

+

+(defmethod render-mpd-command ((command symbol) args)

+  (declare (ignore args))

+  (when (keywordp command)

+    (string-downcase command)))

new file mode 100644

@@ -0,0 +1,10 @@

+;;;; package.lisp

+

+(defpackage #:mpd-remote.song

+  (:use #:cl #:alexandria #:serapeum)

+  (:export #:parse-song #:split-songs))

+

+(defpackage #:mpd-remote

+  (:use #:cl #:alexandria #:serapeum #:mpd-remote.song)

+  (:export #:with-mpd-connection #:send-command))

+

new file mode 100644

@@ -0,0 +1,67 @@

+(in-package #:mpd-remote.song)

+

+(defclass song ()

+  ((tags :accessor tags :initform (make-hash-table :test 'equalp))))

+

+(defmacro define-tag-accessor (name class &optional (tag name))

+  `(defgeneric ,name (song)

+     (:method ((song ,class))

+       (gethash ,(string tag)

+		(tags song)))))

+

+(defmacro define-tag-accessors ((class) &body tags)

+  `(progn

+     ,@(loop for (name tag) in (fw.lu:ensure-mapping tags)

+	  collect `(define-tag-accessor ,name ,class,tag))))

+

+

+

+(define-tag-accessors (song)

+  file artist album title genre last-modified track date (track-length time) pos)

+

+(defmethod print-object ((song song) stream)

+  (print-unreadable-object (song stream :type t :identity t)

+    (with-accessors ((tags tags)) song

+      (format stream "(~a - ~a)"

+	      (gethash "title" tags)

+	      (gethash "artist" tags)))))

+

+(defun parse-tag (tag value)

+  (string-case:string-case ((string-downcase tag) :default value)

+    ("track" (mapcar #'parse-integer

+		     (split-sequence #\/ value)))

+    ("disc" (mapcar #'parse-integer

+		    (split-sequence #\/ value)))

+    ("time" (parse-integer value))  

+    ("pos" (parse-integer value))

+    ("date" (parse-integer value))))

+

+(defun parse-song (lines)

+  (let ((song (make-instance 'song)))

+    (dolist (line lines song)

+      (destructuring-bind (tag value) (split-sequence #\: line :count 2)

+	(setf (gethash tag (tags song))

+	      (parse-tag tag (trim-whitespace value)))))))

+

+(defun split-songs (lines)

+  (let* ((result (list (list))))

+    (dolist (line lines (mapcar #'nreverse (cdr (nreverse result))))

+      (when (starts-with-subseq "file:" line)

+	(push (list) result))

+      (push line (car result)))))

+				

+	 

+(defun parse-search (lines)

+  (declare (optimize (debug 3)))

+  (loop with result = (make-array 0 :adjustable t :fill-pointer 0)

+     with current = (list)

+     for line in lines

+     for (tag value) = (split-sequence #\: line)

+

+     when (string-equal tag "file") do

+       (vector-push-extend current result)

+       (setf current (list))

+

+     do (push (vector tag (string-trim '(#\space #\tab) value))

+	      current)

+     finally (return result)))