;; mpd-client.scm
;; client library for mpd (http://www.musicpd.org)

; (define-extension mpd-client)
(require-extension tcp regex srfi-1)

(module mpd-client
  (;; mpd connection
   mpd-connection?
   mpd-host mpd-port mpd-password mpd-version
   connect disconnect ping

   ;; server information and status
   get-commands get-stats get-status clear-error! shutdown-server!
   get-output-devices enable-output-device! disable-output-device!
   set-options!

   ;; query and modify playlist
   add-song! move-song! remove-song! swap-songs!
   shuffle-playlist! clear-playlist!
   load-playlist! save-playlist! remove-playlist!
   get-current-song get-playlist get-playlist-changes
   by-position
   
   ;; song database
   find-songs search-songs list-metadata list-directory list-directory/r
   update-song-database!
  
   ;; playback control
   play! pause! stop! next-song! previous-song!)

  (import scheme chicken)
  (import (only data-structures string-translate string-split)
          (only extras read-line)
          (only ports with-output-to-string)
          (only regex regexp string-search)
          (only tcp tcp-connect)
          (only srfi-1 filter-map))
  
  (define-record-type :mpd-conn
    (make-mpd-conn host port password i o version time)
    mpd-connection?
    (host mpd-host)
    (port mpd-port)
    (password mpd-password)
    (i in-port in-port-set!)
    (o out-port out-port-set!)
    (version mpd-version mpd-version-set!)
    (time last-contact-time last-contact-time-set!))

  (define-record-type :by-position
    (by-position pos)
    by-position?
    (pos position))
  
  (define (update-time conn)
    (last-contact-time-set! conn (current-seconds)))

  (define re-ok+version (regexp "^OK MPD (.*)$"))
  (define re-err (regexp "^ACK ?(.*)$"))
  (define re-pair (regexp "^([^:]+): (.*)$"))

  (define (raise-mpd-error msg . args)
    (abort
     (make-composite-condition
      (make-property-condition 'exn 'message msg 'arguments args)
      (make-property-condition 'mpd))))

  (define (connect #!optional (host "localhost") (port 6600) password)
    (reconnect (make-mpd-conn host port password #f #f #f 0)))

  (define (reconnect conn)
    (if (in-port conn)
        (disconnect conn))
    (receive (i o) (tcp-connect (mpd-host conn) (mpd-port conn))
      (let ((l (read-line i)))
        (cond
         ((eof-object? l)
          (close-input-port i)
          (close-output-port o)
          (raise-mpd-error "connection closed unexpectedly"))
         ((string-search re-ok+version l)
          => (lambda (m)
               (in-port-set! conn i)
               (out-port-set! conn o)
               (mpd-version-set! conn (cadr m))
               (update-time conn)
               (cond ((mpd-password conn) => (cut cmd conn "password" <>)))
               conn))
         (else
          (close-input-port i)
          (close-output-port o)
          (raise-mpd-error "unexpected greeting" l))))))

  (define (disconnect conn)
    (close-input-port (in-port conn))
    (close-output-port (out-port conn))
    (in-port-set! conn #f)
    (out-port-set! conn #f)
    (last-contact-time-set! conn 0)
    (void))

  (define (ping conn)
    (send-command conn "ping" '())
    (let ((l (read-line (in-port conn))))
      (cond
       ((eof-object? l)
        (reconnect conn))
       ((equal? l "OK")
        (update-time conn))
       (else
        (update-time conn)
        (raise-mpd-error "unexpected line from server" l)))))

  (define (check-connection conn)
    (let ((i (in-port conn)))
      (cond
       ((and (char-ready? i)
             (eof-object? (peek-char i)))
        (reconnect conn))
       ((> (current-seconds)
           (+ (last-contact-time conn) 30))
        (ping conn)))))

  (define (get-result conn)
    (let loop ((l (read-line (in-port conn))) (r '()))
      (cond
       ((eof-object? l)
        (disconnect conn)
        (raise-mpd-error "connection closed unexpectedly"))
       ((equal? l "OK")
        (update-time conn)
        (reverse r))
       ((string-search re-err l)
        => (lambda (m)
             (update-time conn)
             (raise-mpd-error "error from server" (cadr m))))
       ((string-search re-pair l)
        => (lambda (m)
             (let ((s (string->symbol (cadr m))))
               (loop (read-line (in-port conn))
                     (cons (cons s (convert-type s (caddr m)))
                           r)))))
       (else
        (update-time conn)
        (raise-mpd-error "unexpected line from server" l)))))

  (define playlist-is-number (make-parameter #f))

  (define (convert-type k v)
    (case k
      ((volume playlistlength song songid bitrate xfade
               Id Pos Time Track
               artists albums songs uptime playtime db_playtime db_update
               updating_db outputid cpos)
       (string->number v))
      ((playlist)
       (if (playlist-is-number)
           (string->number v)
           v))
      ((time audio)
       (map string->number (string-split v ":")))
      ((repeat random outputenabled)
       (not (string=? v "0")))
      ((state)
       (string->symbol v))
      (else v)))

  (define (send-command conn cmd args)
    (display
     (with-output-to-string
       (lambda ()
         (display cmd)
         (for-each
          (lambda (arg)
            (when arg
              (display " ")
              (display
               (cond
                ((string? arg)
                 (string-append "\"" (string-translate arg "\"") "\""))
                (else arg)))))
          args)
         (newline)))
     (out-port conn))
    (update-time conn))

  (define (cmd conn cmd . args)
    (check-connection conn)
    (send-command conn cmd args)
    (get-result conn))

  (define (result/1-col colname result)
    (filter-map
     (lambda (p)
       (and (eqv? colname (car p)) (cdr p)))
     result))

  (define (result/1-col* result)
    (map cdr result))

  (define (result/m-col result)
    (let loop ((result result) (out '()))
      (cond
       ((null? result)
        (reverse out))
       ((char-lower-case? (string-ref (symbol->string (caar result)) 0))
        (loop (cdr result) (cons (list (car result)) out)))
       (else
        (loop (cdr result) (cons (cons (car result) (car out)) (cdr out)))))))

  (define (result/m-col* result)
    (let loop ((result result) (out '()) (first-key #f))
      (cond
       ((null? result)
        (reverse out))
       ((not first-key)
        (loop result out (caar result)))
       ((eq? first-key (caar result))
        (loop (cdr result) (cons (list (car result)) out) first-key))
       (else
        (loop (cdr result) (cons (cons (car result) (car out)) (cdr out))
              first-key)))))


  ;; server information and status

  (define (get-commands c #!optional (allowed #t))
    (result/1-col 'command (cmd c (if allowed "commands" "notcommands"))))
  (define (get-stats c) (cmd c "stats"))
  (define (get-status c)
    (parameterize ((playlist-is-number #t))
      (cmd c "status")))
  (define (clear-error! c) (cmd c "clearerror"))
  (define (shutdown-server! c) (cmd c "kill"))
  (define (get-output-devices c) (result/m-col* (cmd c "outputs")))
  (define (enable-output-device! c id) (cmd c "enableoutput" id))
  (define (disable-output-device! c id) (cmd c "disableoutput" id))
  (define (set-options! c . opts)
    (when (pair? opts)
      (case (car opts)
        ((#:crossfade) (cmd c "crossfade" (cadr opts)))
        ((#:random)    (cmd c "random" (if (cadr opts) 1 0)))
        ((#:repeat)    (cmd c "repeat" (if (cadr opts) 1 0)))
        ((#:volume)    (cmd c "setvol" (cadr opts)))
        (else          (raise-mpd-error "unknown option" (car opts))))
      (apply set-options! c (cddr opts))))

  ;; query and modify playlist

  (define (add-song! c path) (result/1-col 'Id (cmd c "addid" path)))
  (define (move-song! c from to)
    (if (by-position? from)
        (cmd c "move" (position from) to)
        (cmd c "moveid" from to)))
  (define (remove-song! c song)
    (if (by-position? song)
        (cmd c "delete" (position song))
        (cmd c "deleteid" song)))
  (define (swap-songs! c song1 song2)
    (cond
     ((and (by-position? song1) (by-position? song2))
      (cmd c "swap" (position song1) (position song2)))
     ((and (integer? song1) (integer? song2))
      (cmd c "swapid" song1 song2))
     (else (raise-mpd-error "both songs to be swapped must be specified in the same way"))))
  (define (shuffle-playlist! c) (cmd c "shuffle"))
  (define (clear-playlist! c) (cmd c "clear"))
  (define (load-playlist! c pl) (cmd c "load" pl))
  (define (save-playlist! c n) (cmd c "save" n))
  (define (remove-playlist! c n) (cmd c "rm" n))
  (define (get-current-song c) (cmd c "currentsong"))
  (define (get-playlist c #!optional song)
    (result/m-col
     (if (by-position? song)
         (cmd c "playlistinfo" (position song))
         (cmd c "playlistid" song))))
  (define (get-playlist-changes c version #!optional (full? #t))
    (result/m-col (cmd c (if full? "plchanges" "plchangesposid") version)))

  ;; song database

  (define (find-songs c type s) (result/m-col (cmd c "find" type s)))
  (define (search-songs c type s) (result/m-col (cmd c "search" type s)))
  (define (list-metadata c type #!optional limit s)
    (result/1-col* (cmd c "list" type limit s)))
  (define (list-directory c #!optional dir)
    (result/m-col (cmd c "lsinfo" dir)))
  (define (list-directory/r c #!optional path (full? #t))
    (if full?
        (result/m-col (cmd c "listallinfo" path))
        (cmd c "listall" path)))
  (define (update-song-database! c #!optional path)
    (cmd c "update" path))

  ;; playback control

  (define (play! c #!optional song time)
    (let ((pos? (by-position? song)))
      (cmd c (cond ((and pos? time) "seek")
                   (time "seekid")
                   (pos? "play")
                   (else "playid"))
           (if pos? (position song) song)
           time)))
  (define (pause! c pause?) (cmd c "pause" (if pause? 1 0)))
  (define (stop! c) (cmd c "stop"))
  (define (next-song! c) (cmd c "next"))
  (define (previous-song! c) (cmd c "previous"))

)