rktplayer/dlna-player.rkt

#lang racket

(require racket/class
         racket/path
         racket/udp
         racket-upnp
         "utils.rkt")

(provide dlna-player%)

(define dlna-player%
  (class object%
    (init-field renderer
                [port 8080]
                [time-updater (lambda (time-s length-s) #t)]
                [track-nr-updater (lambda (nr) #t)]
                [state-updater (lambda (state) #t)]
                [track-ended (lambda () #t)]
                [track-changed (lambda (nr) #t)])

    (define lock (make-semaphore 1))
    (define server #f)
    (define poll-thread #f)
    (define stopped #f)
    (define requested-stop #t)
    (define current-state 'stopped)
    (define current-track-nr #f)
    (define current-duration 0)
    (define uri->track-nr (make-hash))

    (define (with-renderer f)
      (call-with-semaphore lock f))

    (define (local-address)
      (let ((socket (udp-open-socket)))
        (dynamic-wind
          void
          (lambda ()
            (udp-connect! socket (media-renderer-address renderer) 1900)
            (let-values (((address local-port remote-address remote-port)
                          (udp-addresses socket #t)))
              address))
          (lambda ()
            (udp-close socket)))))

    (define (start-server)
      (let ((address (local-address)))
        (info-rktplayer
         "Starting DLNA media server on ~a:~a for ~a"
         address
         port
         (media-renderer-name renderer))
        (start-media-file-server
         (format "http://~a:~a/media/" address port)
         #:listen-ip address)))

    (define (file-url file track-nr)
      (let* ((extension (path-get-extension file))
             (name (if extension
                       (format "track-~a~a" track-nr extension)
                       (format "track-~a" track-nr)))
             (uri (media-file-server-publish! server file name)))
        (hash-set! uri->track-nr uri track-nr)
        uri))

    (define (renderer-call what f)
      (with-handlers
        ((exn:fail?
          (lambda (exception)
            (warn-rktplayer
             "Could not ~a on DLNA renderer ~a: ~a"
             what
             (media-renderer-name renderer)
             (exn-message exception))
            #f)))
        (with-renderer f)))

    (define (update-track uri)
      (let ((nr (and uri (hash-ref uri->track-nr uri #f))))
        (when (and nr
                   (or (not current-track-nr)
                       (not (= nr current-track-nr))))
          (set! current-track-nr nr)
          (track-nr-updater nr)
          (track-changed nr))))

    (define (poll)
      (let ((reported-state
             (renderer-call
              "read playback state"
              (lambda ()
                (media-renderer-status renderer)))))
        (when reported-state
          (let ((state (if (eq? reported-state 'no-media)
                           'stopped
                           reported-state)))
          (unless (eq? state current-state)
            (set! current-state state)
            (state-updater state))
          (when (or (eq? state 'playing)
                    (eq? state 'paused)
                    (eq? state 'transitioning))
            (let ((position
                   (renderer-call
                    "read playback position"
                    (lambda ()
                      (media-renderer-position renderer)))))
              (when position
                (let ((seconds (transport-position-seconds position))
                      (duration (transport-position-duration position)))
                  (when (and seconds duration)
                    (set! current-duration duration)
                    (time-updater seconds duration))
                  (update-track (transport-position-uri position))))))
          (when (and (eq? state 'stopped)
                     (not requested-stop))
            (set! requested-stop #t)
            (track-ended))))))

    (define (poll-loop)
      (let loop ()
        (unless stopped
          (with-handlers
            ((exn:fail?
              (lambda (exception)
                (warn-rktplayer
                 "DLNA polling failed for ~a: ~a"
                 (media-renderer-name renderer)
                 (exn-message exception)))))
            (poll))
          (sleep 0.5)
          (loop))))

    (define/public (name)
      (media-renderer-name renderer))

    (define/public (next-uri-supported?)
      (and (renderer-call
            "inspect supported actions"
            (lambda ()
              (media-renderer-next-uri-supported? renderer)))
           #t))

    (define/public (play-file! file track-nr
                               #:next-file (next-file #f)
                               #:next-track-nr (next-track-nr #f))
      (let ((uri (file-url file track-nr))
            (next-uri (and next-file
                           next-track-nr
                           (file-url next-file next-track-nr))))
        (set! requested-stop #f)
        (set! current-track-nr track-nr)
        (track-nr-updater track-nr)
        (state-updater 'transitioning)
        (if next-uri
            (with-renderer
             (lambda ()
               (media-renderer-play-uri!
                renderer
                uri
                #:next-uri next-uri)))
            (with-renderer
             (lambda ()
               (media-renderer-play-uri! renderer uri))))))

    (define/public (set-next-file! file track-nr)
      (let ((uri (file-url file track-nr)))
        (with-renderer
         (lambda ()
           (media-renderer-set-next-uri! renderer uri)))))

    (define/public (clear-next!)
      (with-renderer
       (lambda ()
         (media-renderer-set-next-uri! renderer ""))))

    (define/public (pause!)
      (with-renderer
       (lambda ()
         (media-renderer-pause! renderer))))

    (define/public (play!)
      (with-renderer
       (lambda ()
         (media-renderer-play! renderer))))

    (define/public (stop!)
      (set! requested-stop #t)
      (with-renderer
       (lambda ()
         (media-renderer-stop! renderer))))

    (define/public (seek! percentage)
      (when (> current-duration 0)
        (with-renderer
         (lambda ()
           (media-renderer-seek!
            renderer
            (* current-duration (/ percentage 100.0)))))))

    (define/public (volume)
      (or (renderer-call
           "read volume"
           (lambda ()
             (media-renderer-volume renderer)))
          0))

    (define/public (set-volume! percentage)
      (renderer-call
       "set volume"
       (lambda ()
         (media-renderer-set-volume!
          renderer
          (max 0
               (min 100
                    (inexact->exact
                     (round percentage))))))))

    (define/public (quit)
      (set! requested-stop #t)
      (set! stopped #t)
      (when poll-thread
        (kill-thread poll-thread))
      (with-handlers
        ((exn:fail?
          (lambda (exception)
            (dbg-rktplayer
             "Could not stop DLNA renderer while quitting: ~a"
             (exn-message exception)))))
        (with-renderer
         (lambda ()
           (media-renderer-stop! renderer))))
      (when server
        (media-file-server-stop! server)
        (set! server #f)))

    (super-new)

    (begin
      (set! server (start-server))
      (set! poll-thread (thread poll-loop))
      (info-rktplayer
       "DLNA player initialized for ~a"
       (media-renderer-name renderer)))))