#lang racket/base

(require racket-audio-dlna
         racket/list
         racket/path
         racket/string
         simple-log
         "library.rkt")

(provide make-dlna-playback
         dlna-playback-play-index!
         dlna-playback-pause!
         dlna-playback-resume!
         dlna-playback-stop!
         dlna-playback-seek-percentage!
         dlna-playback-volume!
         dlna-playback-repeat!
         dlna-playback-close!)

(sl-def-log web-player-dlna)

;; This module deliberately contains only playlist orchestration. Transport,
;; HTTP publication, metadata, polling and seeking remain the responsibility
;; of racket-audio-dlna.
(struct dlna-playback
  (player
   tracks
   update
   error
   [repeat #:mutable]
   [current-index #:mutable]
   [current-uri #:mutable]
   [prepared-index #:mutable]
   [playing-seen? #:mutable]
   [progress-seen? #:mutable]
   [failure-active? #:mutable]
   [stop-requested? #:mutable]
   [stopped-polls #:mutable]
   [play-request-ms #:mutable]
   [reachable? #:mutable]
   [running? #:mutable]
   [monitor #:mutable]
   lock)
  #:transparent)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define playback-start-timeout-ms 8000)

;;; Returns the current time used to measure renderer start delays.
(define (now-ms)
  (current-inexact-milliseconds))

;;; Maps renderer-specific transport states to the web player's states.
(define (normalize-state state)
  (cond
    ((eq? state 'transitioning) 'starting)
    ((member state '(initialized no-media)) 'stopped)
    (else state)))

;;; Determines whether state or position confirms that playback has started.
;; Position reporting is optional and notably unreliable on some Denon
;; renderers. PLAYING, TRANSITIONING or PAUSED is itself confirmation that the
;; renderer accepted the transport. A positive position remains useful for
;; devices whose transport state lags behind their position response.
(define (renderer-confirms-playback? state position)
  (cond
    ((member state '(playing starting paused)) #t)
    ((and (number? position) (> position 0)) #t)
    (else #f)))

;;; Runs a playback operation while holding its synchronization lock.
(define (with-lock playback proc)
  (call-with-semaphore (dlna-playback-lock playback) proc))

;;; Reads the current playlist through the callback supplied by the owner.
(define (current-tracks playback)
  ((dlna-playback-tracks playback)))

;;; Checks whether index identifies a track in the current playlist.
(define (valid-index? playback index)
  (and (exact-nonnegative-integer? index)
       (< index (length (current-tracks playback)))))

;;; Returns the track at index, or #f when the index is invalid.
(define (track-at playback index)
  (if (valid-index? playback index)
      (list-ref (current-tracks playback) index)
      #f))

;;; Produces a complete path string for stable renderer file comparison.
(define (normalized-file file)
  (with-handlers ((exn:fail? (λ (_) (format "~a" file))))
    (path->string (path->complete-path file))))

;;; Compares two track files using the path rules of the current platform.
(define (same-file? first second)
  (cond
    ((eq? first #f) #f)
    ((eq? second #f) #f)
    (else
     (let ((same-path? (if (eq? (system-type 'os) 'windows)
                           string-ci=?
                           string=?)))
       (same-path? (normalized-file first)
                   (normalized-file second))))))

;;; Selects the following playlist index according to the repeat setting.
(define (next-index playback index)
  (let ((count (length (current-tracks playback))))
    (cond
      ((zero? count) #f)
      ((eq? (dlna-playback-repeat playback) 'one) index)
      ((< (+ index 1) count) (+ index 1))
      ((eq? (dlna-playback-repeat playback) 'all) 0)
      (else #f))))

;;; Finds the playlist index represented by renderer metadata.
;;; A prepared index is checked first before searching the complete playlist.
(define (track-index-for-info playback info)
  (let* ((info-track (dlna-info-track info))
         (file (if (eq? info-track #f)
                   #f
                   (dlna-track-info-file info-track)))
         (prepared (dlna-playback-prepared-index playback)))
    (if (and (valid-index? playback prepared)
             (same-file? file (track-file (track-at playback prepared))))
        prepared
        (let loop ((remaining (current-tracks playback))
                   (index 0))
          (cond
            ((null? remaining) #f)
            ((same-file? file (track-file (car remaining))) index)
            (else
             (loop (cdr remaining) (add1 index))))))))

;;; Sends the current playback state and renderer information to the owner.
(define (notify! playback state info)
  ((dlna-playback-update playback)
   state
   (dlna-playback-current-index playback)
   info))

;;; Records a playback failure and forwards its detail to the error callback.
(define (report-failure! playback detail)
  (set-dlna-playback-playing-seen?! playback #f)
  (set-dlna-playback-progress-seen?! playback #f)
  (set-dlna-playback-failure-active?! playback #t)
  (set-dlna-playback-play-request-ms! playback #f)
  (set-dlna-playback-stopped-polls! playback 0)
  ((dlna-playback-error playback) detail))

;;; Prepares the next track on renderers that support gapless continuation.
(define (prepare-next! playback)
  (let ((current (dlna-playback-current-index playback)))
    (when (valid-index? playback current)
      (let ((following (next-index playback current)))
        (cond
          ((eq? following #f)
           (set-dlna-playback-prepared-index! playback #f))
          ((not (equal? following (dlna-playback-prepared-index playback)))
           (with-handlers
               ((exn:fail?
                 (λ (exception)
                   (set-dlna-playback-prepared-index! playback #f)
                   (warn-web-player-dlna
                    "Could not prepare next DLNA track: ~a"
                    (exn-message exception)))))
             (dlna-player-set-next-file!
              (dlna-playback-player playback)
              (track-file (track-at playback following)))
             (set-dlna-playback-prepared-index! playback following))))))))

;;; Starts one playlist item while the caller holds the playback lock.
(define (play-index/locked! playback index)
  (let ((item (track-at playback index)))
    (unless item
      (raise-arguments-error
       'dlna-playback-play-index!
       "track index is outside the playlist"
       "index" index))
    (with-handlers
        ((exn:fail?
          (λ (exception)
            (report-failure! playback (exn-message exception))
            (raise exception))))
      (dlna-player-play! (dlna-playback-player playback) (track-file item))
      (let ((info (dlna-player-info (dlna-playback-player playback))))
        (set-dlna-playback-current-index! playback index)
        (set-dlna-playback-current-uri! playback (dlna-info-uri info))
        (set-dlna-playback-prepared-index! playback #f)
        (set-dlna-playback-playing-seen?! playback #t)
        (set-dlna-playback-progress-seen?! playback #f)
        (set-dlna-playback-failure-active?! playback #f)
        (set-dlna-playback-play-request-ms! playback (now-ms))
        (set-dlna-playback-stop-requested?! playback #f)
        (set-dlna-playback-stopped-polls! playback 0)
        (notify! playback 'starting info)
        (prepare-next! playback)))))

;;; Updates the current index when renderer metadata identifies another track.
(define (update-current-track! playback info)
  (let ((index (track-index-for-info playback info)))
    (when (valid-index? playback index)
      (unless (equal? index (dlna-playback-current-index playback))
        (set-dlna-playback-progress-seen?! playback #f)
        (set-dlna-playback-play-request-ms! playback (now-ms)))
      (set-dlna-playback-current-index! playback index)
      (set-dlna-playback-prepared-index! playback #f)
      (prepare-next! playback))))

;;; Advances to the next track or stops when the playlist has ended.
(define (advance! playback)
  (let* ((current (dlna-playback-current-index playback))
         (following (if (valid-index? playback current)
                        (next-index playback current)
                        #f)))
    (if (eq? following #f)
        (begin
          (dlna-player-stop! (dlna-playback-player playback))
          (notify! playback
                   'stopped
                   (dlna-player-info (dlna-playback-player playback))))
        (play-index/locked! playback following))))

;;; Processes one successful renderer poll while the playback lock is held.
;;; It updates track identity, start confirmation and end-of-track handling.
(define (poll-reachable/locked! playback info)
  (let ((state (normalize-state (dlna-info-state info)))
        (uri (dlna-info-uri info))
        (position (dlna-info-position info)))
    (set-dlna-playback-reachable?! playback #t)
    (when (and (string? uri)
               (not (string=? uri ""))
               (not (equal? uri (dlna-playback-current-uri playback))))
      (set-dlna-playback-current-uri! playback uri)
      (set-dlna-playback-stopped-polls! playback 0)
      (update-current-track! playback info))
    (when (renderer-confirms-playback? state position)
      (set-dlna-playback-progress-seen?! playback #t))
    (let* ((request-ms (dlna-playback-play-request-ms playback))
           (elapsed-ms (if (eq? request-ms #f)
                           #f
                           (- (now-ms) request-ms)))
           (failed-now?
            (and (dlna-playback-playing-seen? playback)
                 (not (dlna-playback-progress-seen? playback))
                 elapsed-ms
                 (>= elapsed-ms playback-start-timeout-ms))))
      ;;; Handles a stopped renderer after start and progress checks complete.
      (define (handle-stopped!)
        (cond
          ((and (not (dlna-playback-progress-seen? playback))
                elapsed-ms
                (< elapsed-ms 5000))
           (void))
          ((not (dlna-playback-progress-seen? playback))
           (warn-web-player-dlna
            "DLNA renderer stopped without confirming playback: position=~a uri=~a"
            position (or uri ""))
           (report-failure!
            playback
            'dlna-renderer-no-start-of-track-confirmation))
          (else
           (set-dlna-playback-stopped-polls!
            playback
            (+ 1 (dlna-playback-stopped-polls playback)))
           ;; Give SetNextAVTransportURI one poll to take over. Some renderers
           ;; need the explicit fallback on the next poll.
           (when (or (eq? (dlna-playback-prepared-index playback) #f)
                     (> (dlna-playback-stopped-polls playback) 1))
             (set-dlna-playback-playing-seen?! playback #f)
             (set-dlna-playback-stopped-polls! playback 0)
             (advance! playback)))))
      (when failed-now?
        (warn-web-player-dlna
         "DLNA start was not confirmed: state=~a position=~a uri=~a"
         state position (or uri ""))
        (report-failure!
         playback
         'dlna-renderer-no-start-of-track-confirmation))
      (unless (or failed-now? (dlna-playback-failure-active? playback))
        (cond
          ((eq? state 'playing)
           (set-dlna-playback-playing-seen?! playback #t)
           (set-dlna-playback-stopped-polls! playback 0))
          ((and (eq? state 'stopped)
                (dlna-playback-stop-requested? playback))
           (set-dlna-playback-stop-requested?! playback #f)
           (set-dlna-playback-stopped-polls! playback 0))
          ((and (eq? state 'stopped)
                (dlna-playback-playing-seen? playback))
           (handle-stopped!))))
      (notify!
       playback
       (cond
         ((or failed-now? (dlna-playback-failure-active? playback))
          'stopped)
         ((and (dlna-playback-playing-seen? playback)
               (not (dlna-playback-progress-seen? playback)))
          'starting)
         (else state))
         info))))

;;; Polls the renderer and reports a transition to an unreachable state once.
(define (poll/locked! playback)
  (let ((info (dlna-player-info (dlna-playback-player playback))))
    (if (dlna-info-reachable? info)
        (poll-reachable/locked! playback info)
        (when (dlna-playback-reachable? playback)
          (set-dlna-playback-reachable?! playback #f)
          ((dlna-playback-error playback)
           'dlna-renderer-unreachable)))))

;;; Polls the renderer until playback is closed, logging recoverable failures.
(define (monitor-loop playback poll-seconds)
  (let loop ()
    (when (dlna-playback-running? playback)
      (sleep poll-seconds)
      (when (dlna-playback-running? playback)
        (with-handlers
            ((exn:fail?
              (λ (exception)
                (warn-web-player-dlna
                 "Could not update DLNA playback state: ~a"
                 (exn-message exception)))))
          (with-lock playback (λ () (poll/locked! playback))))
        (loop)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create playlist-aware playback for one network renderer.
; pre    : Device is a media renderer, callbacks are procedures, and
;          media-server is a running shared media-file-server.
; post   : A DLNA player and its state-monitor thread are running.
; result : A playback adapter that publishes through the supplied server.
; internals: make-dlna-player creates the renderer interface; monitor-loop polls
;            it periodically. poll/locked! reconciles URI, transport state and
;            position with the playlist and reports updates, failures or track
;            advancement. with-lock orders polls and commands using the
;            dlna-playback-lock accessor generated for the struct's lock field.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-dlna-playback device
                            tracks
                            update
                            error
                            #:media-file-server media-server
                            #:poll-seconds [poll-seconds 1])
  (let* ((raw (make-dlna-player device
                                #:media-file-server media-server))
         (playback
          (dlna-playback raw tracks update error 'off #f #f #f
                         #f #f #f #f 0 #f #t #t #f
                         (make-semaphore 1))))
    (set-dlna-playback-monitor!
     playback
     (thread (λ () (monitor-loop playback poll-seconds))))
    playback))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Start the track at index in the current playlist.
; pre    : Playback is open and index identifies an existing track.
; post   : The renderer starts the track and the next track is prepared.
; result : The result of the synchronized playback operation.
; internals: Playback state changes and callbacks run while holding the lock.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-play-index! playback index)
  (with-lock playback (λ () (play-index/locked! playback index))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Pause the current renderer transport.
; pre    : Playback is open and the renderer accepts pause requests.
; post   : The renderer is paused and listeners receive the new state.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after the pause request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-pause! playback)
  (with-lock
   playback
   (λ ()
     (dlna-player-pause! (dlna-playback-player playback))
     (notify! playback 'paused (dlna-player-info (dlna-playback-player playback))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Resume the paused renderer transport.
; pre    : Playback is open and the renderer accepts resume requests.
; post   : The renderer is playing and listeners receive the new state.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after the resume request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-resume! playback)
  (with-lock
   playback
   (λ ()
     (dlna-player-resume! (dlna-playback-player playback))
     (notify! playback 'playing (dlna-player-info (dlna-playback-player playback))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Stop the current renderer transport.
; pre    : Playback is open.
; post   : Pending start and failure state is cleared and listeners see stopped.
; result : The result of the synchronized playback operation.
; internals: stop-requested? distinguishes this stop from a finished track.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-stop! playback)
  (with-lock
   playback
   (λ ()
     (set-dlna-playback-stop-requested?! playback #t)
     (set-dlna-playback-playing-seen?! playback #f)
     (set-dlna-playback-progress-seen?! playback #f)
     (set-dlna-playback-failure-active?! playback #f)
     (set-dlna-playback-play-request-ms! playback #f)
     (set-dlna-playback-stopped-polls! playback 0)
     (dlna-player-stop! (dlna-playback-player playback))
     (notify! playback 'stopped (dlna-player-info (dlna-playback-player playback))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Seek to a percentage of the current track.
; pre    : Playback is open and percentage is accepted by the DLNA player.
; post   : The renderer position and listener state reflect the requested seek.
; result : The result of the synchronized playback operation.
; internals: The synchronously refreshed DLNA cache is published immediately.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-seek-percentage! playback percentage)
  (with-lock
   playback
   (λ ()
     (dlna-player-seek-percentage! (dlna-playback-player playback) percentage)
     ;; racket-audio-dlna updates its cache synchronously after Seek. Publish
     ;; that value immediately so the web slider does not jump back.
     (let ((info (dlna-player-info (dlna-playback-player playback))))
       (notify! playback
                (normalize-state (dlna-info-state info))
                info)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Set the renderer volume to a percentage.
; pre    : Playback is open and percentage is accepted by the DLNA player.
; post   : The renderer volume and listener state reflect the requested value.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after changing the volume.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-volume! playback percentage)
  (with-lock
   playback
   (λ ()
     (dlna-player-volume! (dlna-playback-player playback) percentage)
     (let ((info (dlna-player-info (dlna-playback-player playback))))
       (notify! playback
                (normalize-state (dlna-info-state info))
                info)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Change playlist repeat behavior.
; pre    : Playback is open and repeat is 'off, 'one or 'all.
; post   : The next prepared track reflects the new repeat behavior.
; result : The result of the synchronized playback operation.
; internals: Any previously prepared index is discarded before recalculation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-repeat! playback repeat)
  (with-lock
   playback
   (λ ()
     (set-dlna-playback-repeat! playback repeat)
     (set-dlna-playback-prepared-index! playback #f)
     (prepare-next! playback))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Close playback and release its renderer resources.
; pre    : Playback was created by make-dlna-playback.
; post   : The monitor has stopped and the underlying DLNA player is closed.
; result : Void.
; internals: The running flag prevents repeated closure of the same player.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-close! playback)
  (when (dlna-playback-running? playback)
    (set-dlna-playback-running?! playback #f)
    (let ((monitor (dlna-playback-monitor playback)))
      (when (and monitor (not (thread-dead? monitor)))
        (kill-thread monitor))
      (set-dlna-playback-monitor! playback #f)
      (with-lock
       playback
       (λ ()
         (dlna-player-close! (dlna-playback-player playback)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module dlna-playback.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module+ test
  (require rackunit)

  (define first
    (track (build-path "music" "01.flac")
           "First" "Artist" "Album" 60 "audio/flac"))
  (define second
    (track (build-path "music" "02.flac")
           "Second" "Artist" "Album" 60 "audio/flac"))
  (define playback
    (dlna-playback #f (λ () (list first second)) void void
                   'off 0 #f #f #f #f #f #f 0 #f #t #f #f
                   (make-semaphore 1)))

  (check-equal? (next-index playback 0) 1)
  (check-false (next-index playback 1))
  (set-dlna-playback-repeat! playback 'all)
  (check-equal? (next-index playback 1) 0)
  (set-dlna-playback-repeat! playback 'one)
  (check-equal? (next-index playback 1) 1)

  (let ((second-info
         (dlna-info
          'playing
          (dlna-track-info (track-file second) "Second" "Artist" "Album"
                           #f #f #f 60 #f #f #f)
          "http://renderer.test/02.flac"
          #f #f 1 60 25 #f #t)))
    (set-dlna-playback-prepared-index! playback 1)
    (check-equal? (track-index-for-info playback second-info) 1)
    (set-dlna-playback-prepared-index! playback #f)
    (check-equal? (track-index-for-info playback second-info) 1)
    (check-false
     (track-index-for-info
      playback
      (struct-copy dlna-info second-info (track #f)))))
  (check-eq? (normalize-state 'transitioning) 'starting)
  (check-eq? (normalize-state 'no-media) 'stopped)
  (check-true (renderer-confirms-playback? 'playing #f))
  (check-true (renderer-confirms-playback? 'starting 0))
  (check-true (renderer-confirms-playback? 'paused #f))
  (check-true (renderer-confirms-playback? 'unknown 1))
  (check-false (renderer-confirms-playback? 'stopped 0)))