rktplayer/dlna-player.rkt

#lang racket

(require racket/class
         racket/path
         (prefix-in rad: racket-audio-dlna)
         "utils.rkt")

(provide dlna-player%)

(define dlna-player%
  (class object%
    (init-field [renderer #f]
                [settings #f]
                [time-updater (lambda (time-s length-s) #t)]
                [track-nr-updater (lambda (nr) #t)]
                [state-updater (lambda (state) #t)]
                [repeat-updater (lambda (state) #t)]
                [audio-info-cb (lambda (rate channels bits kind) #t)]
                [buffer-max-seconds 10]
                [buffer-min-seconds 4]
                [server-url #f]
                [server-port 8734] ;8080]
                [listen-ip #f]
                [poll-seconds 1.0]
                [volume-poll-seconds 5.0])

    (define player #f)
    (define playlist #f)
    (define state 'stopped)
    (define repeat 'no-repeat)
    (define current-track-nr #f)
    (define current-uri #f)
    (define prepared-next-track-nr #f)
    (define playing-seen? #f)
    (define stop-requested? #f)
    (define stopped-polls 0)
    (define renderer-reachable? #t)
    (define running #t)
    (define poll-thread #f)

    (define (check-player)
      (when (eq? renderer #f)
        (raise-arguments-error
         'dlna-player%
         "no media renderer has been configured"
         "renderer" renderer))
      (when (eq? player #f)
        (unless (eq? server-url #f)
          (warn-rktplayer
           "server-url is ignored; racket-audio-dlna determines the server URL"))
        (set! player
              (rad:make-dlna-player
               renderer
               #:listen-ip listen-ip
               #:port server-port
               #:path "/rktplayer/"
               #:poll-seconds poll-seconds
               #:volume-poll-seconds volume-poll-seconds))))

    (define (normalize-state st)
      (cond
        [(or (eq? st 'playing)
             (eq? st 'transitioning))
         'playing]
        [(eq? st 'paused) 'paused]
        [(or (eq? st 'stopped)
             (eq? st 'no-media))
         'stopped]
        [else st]))

    (define (set-state! st)
      (unless (eq? state st)
        (set! state st)
        (state-updater state))
      (repeat-updater repeat)
      (when (or (eq? state 'stopped)
                (eq? state 'quit))
        (audio-info-cb 0 0 0 'none)))

    (define (file-format file)
      (let ((match
             (and file
                  (regexp-match
                   #px"(?i:[.]([a-z0-9]+))$"
                   (path->string file)))))
        (if match
            (string->symbol (string-downcase (cadr match)))
            'none)))

    (define (track-audio-info! track)
      (if track
          (audio-info-cb
           (or (rad:dlna-track-info-sample-rate track) 0)
           (or (rad:dlna-track-info-channels track) 0)
           0
           (file-format (rad:dlna-track-info-file track)))
          (audio-info-cb 0 0 0 'none)))

    (define (normalized-file file)
      (with-handlers ([exn:fail? (lambda (_) (format "~a" file))])
        (path->string (path->complete-path file))))

    (define (same-file? file1 file2)
      (and file1
           file2
           ((if (eq? (system-type 'os) 'windows)
                string-ci=?
                string=?)
            (normalized-file file1)
            (normalized-file file2))))

    (define (playlist-track-file nr)
      (send (send playlist track nr) get-file))

    (define (playlist-track-nr file)
      (and playlist
           (for/first ([nr (in-range (send playlist length))]
                       #:when (same-file? file (playlist-track-file nr)))
             nr)))

    (define (next-track-nr nr)
      (let ((length (send playlist length)))
        (cond
          [(eq? repeat 'repeat-one) nr]
          [(eq? repeat 'repeat-all)
           (if (= (+ nr 1) length) 0 (+ nr 1))]
          [(< (+ nr 1) length) (+ nr 1)]
          [else #f])))

    (define (prepare-next-track!)
      (when (and player
                 playlist
                 (exact-nonnegative-integer? current-track-nr))
        (let ((nr (next-track-nr current-track-nr)))
          (cond
            [(eq? nr #f)
             (set! prepared-next-track-nr #f)]
            [(not (equal? nr prepared-next-track-nr))
             (with-handlers
                 ([exn:fail?
                   (lambda (e)
                     (set! prepared-next-track-nr #f)
                     (warn-rktplayer
                      "Could not prepare next DLNA track: ~a"
                      (exn-message e)))])
               (rad:dlna-player-set-next-file!
                player
                (playlist-track-file nr))
               (set! prepared-next-track-nr nr))]))))

    (define (update-current-track! info)
      (let* ((track (rad:dlna-info-track info))
             (file (and track (rad:dlna-track-info-file track)))
             (nr (cond
                   [(and (exact-nonnegative-integer?
                          prepared-next-track-nr)
                         (same-file?
                          file
                          (playlist-track-file prepared-next-track-nr)))
                    prepared-next-track-nr]
                   [else (playlist-track-nr file)])))
        (when (exact-nonnegative-integer? nr)
          (set! current-track-nr nr)
          (set! prepared-next-track-nr #f)
          (track-nr-updater nr)
          (track-audio-info! track)
          (prepare-next-track!))))

    (define (poll-renderer)
      (when player
        (let ((info (rad:dlna-player-info player)))
          (if (not (rad:dlna-info-reachable? info))
              (when renderer-reachable?
                (set! renderer-reachable? #f)
                (warn-rktplayer "DLNA renderer is not reachable"))
              (let* ((new-state
                      (normalize-state (rad:dlna-info-state info)))
                     (uri (rad:dlna-info-uri info))
                     (position (rad:dlna-info-position info))
                     (duration (rad:dlna-info-duration info)))
                (unless renderer-reachable?
                  (dbg-rktplayer "DLNA renderer is reachable again"))
                (set! renderer-reachable? #t)

                (when (and (string? uri)
                           (not (string=? uri ""))
                           (not (equal? uri current-uri)))
                  (set! current-uri uri)
                  (set! stopped-polls 0)
                  (update-current-track! info))

                (when (or (eq? new-state 'playing)
                          (eq? new-state 'paused))
                  (when (and (number? position)
                             (number? duration))
                    (time-updater position duration))
                  (track-audio-info! (rad:dlna-info-track info)))

                (cond
                  [(eq? new-state 'playing)
                   (set! playing-seen? #t)
                   (set! stopped-polls 0)]
                  [(and (eq? new-state 'stopped)
                        stop-requested?)
                   (set! stop-requested? #f)
                   (set! stopped-polls 0)]
                  [(and (eq? new-state 'stopped)
                        playing-seen?)
                   (set! stopped-polls (+ stopped-polls 1))
                   ;; Give SetNextAVTransportURI one poll to take over.
                   (when (or (eq? prepared-next-track-nr #f)
                             (> stopped-polls 1))
                     (set! playing-seen? #f)
                     (set! stopped-polls 0)
                     (send this next))])

                (set-state! new-state))))))

    (define (poll)
      (let loop ()
        (when running
          (sleep poll-seconds)
          (when running
            (with-handlers
                ([exn:fail?
                  (lambda (e)
                    (warn-rktplayer
                     "Could not update DLNA player state: ~a"
                     (exn-message e)))])
              (poll-renderer))
            (loop)))))

    (define/public (change-player kind
                                  #:host [host #f]
                                  #:basepaths [basepaths #f])
      (void kind host basepaths)
      (warn-rktplayer
       "change-player is not supported by dlna-player%"))

    (define/public (get-volume)
      (check-player)
      (or (rad:dlna-info-volume
           (rad:dlna-player-info player))
          0))

    (define/public (set-volume! percentage)
      (check-player)
      (rad:dlna-player-volume! player percentage))

    (define/public (set-list! playlist*)
      (when player
        (with-handlers ([exn:fail? (lambda (_) (void))])
          (rad:dlna-player-stop! player)))
      (set! playlist playlist*)
      (set! current-track-nr #f)
      (set! current-uri #f)
      (set! prepared-next-track-nr #f)
      (set! playing-seen? #f)
      (set! stop-requested? #f)
      (set! stopped-polls 0)
      (set-state! 'stopped))

    (define/public (playlist! playlist*)
      (check-player)
      (set-list! playlist*))

    (define/public (play playlist*)
      (send this playlist! playlist*)
      (send this play-track 0))

    (define/public (play-track nr)
      (check-player)
      (when (and playlist
                 (>= nr 0)
                 (< nr (send playlist length)))
        (let ((file (playlist-track-file nr)))
          (rad:dlna-player-play! player file)
          (let ((info (rad:dlna-player-info player)))
            (set! current-track-nr nr)
            (set! current-uri (rad:dlna-info-uri info))
            (set! prepared-next-track-nr #f)
            (set! playing-seen? #t)
            (set! stop-requested? #f)
            (set! stopped-polls 0)
            (track-nr-updater nr)
            (track-audio-info! (rad:dlna-info-track info))
            (set-state! 'playing)
            (prepare-next-track!)))))

    (define/public (next)
      (check-player)
      (if (eq? current-track-nr #f)
          (warn-rktplayer
           "No track-nr set (yet), so can't play anything next")
          (let ((nr (next-track-nr current-track-nr)))
            (if (eq? nr #f)
                (send this stop)
                (send this play-track nr)))))

    (define/public (previous)
      (check-player)
      (if (eq? current-track-nr #f)
          (warn-rktplayer
           "No track-nr set (yet), so can't play anything previous")
          (let ((nr current-track-nr))
            (cond
              [(eq? repeat 'repeat-one)
               (send this play-track nr)]
              [(eq? repeat 'repeat-all)
               (send this play-track
                     (if (= nr 0)
                         (- (send playlist length) 1)
                         (- nr 1)))]
              [else
               (send this play-track (max 0 (- nr 1)))]))))

    (define/public (pause!)
      (check-player)
      (rad:dlna-player-pause! player)
      (set-state! 'paused))

    (define/public (play!)
      (check-player)
      (rad:dlna-player-resume! player)
      (set-state! 'playing))

    (define/public (pause-unpause)
      (check-player)
      (if (eq? state 'paused)
          (send this play!)
          (send this pause!)))

    (define/public (stop)
      (check-player)
      (set! stop-requested? #t)
      (set! playing-seen? #f)
      (set! stopped-polls 0)
      (rad:dlna-player-stop! player)
      (set-state! 'stopped))

    (define/public (seek percentage)
      (check-player)
      (rad:dlna-player-seek-percentage! player percentage))

    (define/public (get-repeat)
      (check-player)
      repeat)

    (define/public (repeat! r)
      (check-player)
      (set! repeat r)
      (repeat-updater repeat)
      (prepare-next-track!))

    (define/public (quit)
      (when running
        (set! running #f)
        (unless (eq? poll-thread #f)
          (kill-thread poll-thread)
          (set! poll-thread #f))
        (unless (eq? player #f)
          (rad:dlna-player-close! player)
          (set! player #f))
        (set-state! 'quit)))

    (super-new)

    (begin
      (void settings
            buffer-max-seconds
            buffer-min-seconds)
      (set! poll-thread (thread poll))
      (dbg-rktplayer "dlna-player% initialized"))))