#lang racket/base

;; Stateful local-file player built on racket-audio metadata and racket-upnp.

(require racket/file
         racket/path
         racket/string
         racket/udp
         racket-audio/taglib
         racket-upnp)

(provide make-dlna-player
         dlna-player?
         dlna-player-play!
         dlna-player-set-next-file!
         dlna-player-pause!
         dlna-player-resume!
         dlna-player-stop!
         dlna-player-seek!
         dlna-player-seek-percentage!
         dlna-player-volume!
         dlna-player-muted!
         dlna-player-info
         dlna-player-close!
         (struct-out dlna-track-info)
         (struct-out dlna-info))

(struct dlna-track-info
  (file title artist album genre year track duration
        sample-rate bit-rate channels)
  #:transparent)

(struct dlna-info
  (state track uri next-track next-uri position duration
         volume muted? reachable?)
  #:transparent)

(struct publication
  (track uri metadata)
  #:transparent)

(struct dlna-player
  (renderer
   server
   poll-seconds
   volume-poll-seconds
   transport-lock
   cache-lock
   [current #:mutable]
   [next #:mutable]
   [cached-info #:mutable]
   [position-stamp #:mutable]
   [volume-stamp #:mutable]
   metadata-cache
   [counter #:mutable]
   [running? #:mutable]
   [poll-thread #:mutable])
  #:constructor-name make-dlna-player-state)

(define (now-ms)
  (current-inexact-monotonic-milliseconds))

(define (check-player who player)
  (unless (dlna-player? player)
    (raise-argument-error who "dlna-player?" player))
  (unless (dlna-player-running? player)
    (raise-arguments-error who "DLNA player has been closed")))

(define (nonempty-string value)
  (and (string? value)
       (not (string=? (string-trim value) ""))
       value))

(define (positive-tag-number value)
  (and (exact-integer? value)
       (positive? value)
       value))

(define (tag-string value)
  (cond
    [(string? value) (nonempty-string value)]
    [(and (list? value) (andmap string? value))
     (nonempty-string (string-join value " / "))]
    [else #f]))

(define (file-title path)
  (let* ([name (path->string (file-name-from-path path))]
         [without-extension
          (regexp-replace #px"[.][^.]*$" name "")])
    (if (string=? without-extension "")
        name
        without-extension)))

(define (fallback-track-info path)
  (dlna-track-info path
                   (file-title path)
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f))

(define (read-track-info path)
  (with-handlers ([exn:fail? (lambda (_) (fallback-track-info path))])
    (call-with-id3-tags
     path
     (lambda (tags)
       (if (tags-valid? tags)
           (let* ([artist
                   (or (nonempty-string (tags-artist tags))
                       (tag-string (tags-album-artist tags)))]
                  [duration (positive-tag-number (tags-length tags))])
             (dlna-track-info
              path
              (or (nonempty-string (tags-title tags))
                  (file-title path))
              artist
              (nonempty-string (tags-album tags))
              (nonempty-string (tags-genre tags))
              (positive-tag-number (tags-year tags))
              (positive-tag-number (tags-track tags))
              duration
              (positive-tag-number (tags-sample-rate tags))
              (positive-tag-number (tags-bit-rate tags))
              (positive-tag-number (tags-channels tags))))
           (fallback-track-info path))))))

(define (track-cache-key path)
  (list path
        (file-size path)
        (file-or-directory-modify-seconds path)))

(define (player-track-info who player file)
  (unless (path-string? file)
    (raise-argument-error who "path-string?" file))
  (let ([path (path->complete-path file)])
    (unless (file-exists? path)
      (raise-arguments-error
       who
       "audio file does not exist"
       "file" file))
    (let* ([key (track-cache-key path)]
           [cached
            (call-with-semaphore
             (dlna-player-cache-lock player)
             (lambda ()
               (hash-ref (dlna-player-metadata-cache player) key #f)))])
      (or cached
          (let ([info (read-track-info path)])
            (call-with-semaphore
             (dlna-player-cache-lock player)
             (lambda ()
               (when (>= (hash-count
                          (dlna-player-metadata-cache player))
                         128)
                 (hash-clear! (dlna-player-metadata-cache player)))
               (hash-set! (dlna-player-metadata-cache player) key info)))
            info)))))

(define (file-extension path)
  (let ([match
         (regexp-match #px"(?i:[.]([a-z0-9]+))$"
                       (path->string path))])
    (if match
        (string-append "." (cadr match))
        "")))

(define (next-publication-name player path)
  (call-with-semaphore
   (dlna-player-cache-lock player)
   (lambda ()
     (let ([number (add1 (dlna-player-counter player))])
       (set-dlna-player-counter! player number)
       (format "track-~a~a" number (file-extension path))))))

(define (publish-track! player track)
  (let* ([server (dlna-player-server player)]
         [uri
          (media-file-server-publish!
           server
           (dlna-track-info-file track)
           (next-publication-name
            player
            (dlna-track-info-file track)))])
    (with-handlers
        ([exn:fail?
          (lambda (exception)
            (media-file-server-unpublish! server uri)
            (raise exception))])
      (publication
       track
       uri
       (media-file-server-didl-lite
        server
        uri
        #:title (dlna-track-info-title track)
        #:artist (dlna-track-info-artist track)
        #:album (dlna-track-info-album track)
        #:genre (dlna-track-info-genre track)
        #:year (dlna-track-info-year track)
        #:track (dlna-track-info-track track)
        #:duration (dlna-track-info-duration track))))))

(define (safe-unpublish! player item)
  (when item
    (with-handlers ([exn:fail? (lambda (_) (void))])
      (media-file-server-unpublish!
       (dlna-player-server player)
       (publication-uri item)))))

(define (update-cache! player proc #:position? [position? #f])
  (call-with-semaphore
   (dlna-player-cache-lock player)
   (lambda ()
     (set-dlna-player-cached-info!
      player
      (proc (dlna-player-cached-info player)))
     (when position?
       (set-dlna-player-position-stamp! player (now-ms))))))

(define (set-reachable! player reachable?)
  (update-cache!
   player
   (lambda (info)
     (struct-copy dlna-info info [reachable? reachable?]))))

(define (estimated-info player)
  (call-with-semaphore
   (dlna-player-cache-lock player)
   (lambda ()
     (let* ([info (dlna-player-cached-info player)]
            [position (dlna-info-position info)]
            [duration (dlna-info-duration info)]
            [elapsed
             (/ (- (now-ms) (dlna-player-position-stamp player))
                1000.0)]
            [estimated
             (if (and (eq? (dlna-info-state info) 'playing)
                      (number? position))
                 (+ position (max 0 elapsed))
                 position)])
       (struct-copy
        dlna-info
        info
        [position
         (if (and (number? duration) (number? estimated))
             (min duration estimated)
             estimated)])))))

(define (call-renderer player proc)
  (check-player 'dlna-player player)
  (with-handlers
      ([exn:fail?
        (lambda (exception)
          (set-reachable! player #f)
          (raise exception))])
    (let ([result
           (call-with-semaphore
            (dlna-player-transport-lock player)
            proc)])
      (set-reachable! player #t)
      result)))

(define (promote-or-clear-publications! player uri)
  (let ([old-current #f]
        [old-next #f])
    (when (nonempty-string uri)
      (call-with-semaphore
       (dlna-player-cache-lock player)
       (lambda ()
         (let ([current (dlna-player-current player)]
               [next (dlna-player-next player)])
           (cond
             [(and next (string=? uri (publication-uri next)))
              (set! old-current current)
              (set-dlna-player-current! player next)
              (set-dlna-player-next! player #f)]
             [(and current
                   (not (string=? uri (publication-uri current))))
              (set! old-current current)
              (set! old-next next)
              (set-dlna-player-current! player #f)
              (set-dlna-player-next! player #f)])))))
    (safe-unpublish! player old-current)
    (safe-unpublish! player old-next)))

(define (volume-refresh-due? player)
  (call-with-semaphore
   (dlna-player-cache-lock player)
   (lambda ()
     (>= (- (now-ms) (dlna-player-volume-stamp player))
         (* 1000.0 (dlna-player-volume-poll-seconds player))))))

(define (refresh-volume! player #:force? [force? #f])
  (when (or force? (volume-refresh-due? player))
    (let ([renderer (dlna-player-renderer player)])
      (with-handlers ([exn:fail? (lambda (_) (void))])
        (let ([volume (media-renderer-volume renderer)])
          (update-cache!
           player
           (lambda (info)
             (struct-copy dlna-info info [volume volume])))))
      (with-handlers ([exn:fail? (lambda (_) (void))])
        (let ([muted? (media-renderer-muted? renderer)])
          (update-cache!
           player
           (lambda (info)
             (struct-copy dlna-info info [muted? muted?])))))
      (call-with-semaphore
       (dlna-player-cache-lock player)
       (lambda ()
         (set-dlna-player-volume-stamp! player (now-ms)))))))

(define (refresh-player! player #:force-volume? [force-volume? #f])
  (with-handlers
      ([exn:fail?
        (lambda (_)
          (set-reachable! player #f)
          #f)])
    (call-with-semaphore
     (dlna-player-transport-lock player)
     (lambda ()
       (let* ([renderer (dlna-player-renderer player)]
              [state (media-renderer-status renderer)]
              [position
               (with-handlers ([exn:fail? (lambda (_) #f)])
                 (media-renderer-position renderer))]
              [uri (and position (transport-position-uri position))]
              [seconds
               (and position (transport-position-seconds position))]
              [renderer-duration
               (and position
                    (transport-position-duration position))])
         (promote-or-clear-publications! player uri)
         (let* ([current (dlna-player-current player)]
                [next (dlna-player-next player)]
                [track (and current (publication-track current))]
                [track-duration
                 (and track (dlna-track-info-duration track))]
                [duration
                 (if (and (number? renderer-duration)
                          (positive? renderer-duration))
                     renderer-duration
                     track-duration)])
           (update-cache!
            player
            (lambda (info)
              (struct-copy
               dlna-info
               info
               [state state]
               [track track]
               [uri (or (nonempty-string uri)
                        (and current (publication-uri current)))]
               [next-track (and next (publication-track next))]
               [next-uri (and next (publication-uri next))]
               [position (if (number? seconds)
                             seconds
                             (dlna-info-position info))]
               [duration duration]
               [reachable? #t]))
            #:position? #t))
         (refresh-volume! player #:force? force-volume?)
         #t)))))

(define (poll-player player)
  (let loop ()
    (when (dlna-player-running? player)
      (sleep (dlna-player-poll-seconds player))
      (when (dlna-player-running? player)
        (refresh-player! player)
        (loop)))))

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

(define (server-base-url listen-ip port path)
  (unless (and (exact-integer? port) (<= 1 port 65535))
    (raise-argument-error 'make-dlna-player
                          "exact-integer? between 1 and 65535"
                          port))
  (unless (string? path)
    (raise-argument-error 'make-dlna-player "string?" path))
  (let* ([with-leading
          (if (string-prefix? path "/")
              path
              (string-append "/" path))]
         [normalized
          (if (string-suffix? with-leading "/")
              with-leading
              (string-append with-leading "/"))])
    (format "http://~a:~a~a" listen-ip port normalized)))

(define (make-dlna-player renderer
                          #:listen-ip [listen-ip #f]
                          #:port [port 8080]
                          #:path [path "/racket-audio-dlna/"]
                          #:poll-seconds [poll-seconds 1.0]
                          #:volume-poll-seconds
                          [volume-poll-seconds 5.0])
  (unless (media-renderer? renderer)
    (raise-argument-error 'make-dlna-player "media-renderer?" renderer))
  (unless (or (not listen-ip) (string? listen-ip))
    (raise-argument-error 'make-dlna-player
                          "(or/c #f string?)"
                          listen-ip))
  (unless (and (rational? poll-seconds) (positive? poll-seconds))
    (raise-argument-error 'make-dlna-player
                          "positive-real?"
                          poll-seconds))
  (unless (and (rational? volume-poll-seconds)
               (positive? volume-poll-seconds))
    (raise-argument-error 'make-dlna-player
                          "positive-real?"
                          volume-poll-seconds))
  (let* ([local-address
          (or listen-ip (renderer-local-address renderer))]
         [server
          (start-media-file-server
           (server-base-url local-address port path)
           #:listen-ip local-address)]
         [player
          (make-dlna-player-state
           renderer
           server
           poll-seconds
           volume-poll-seconds
           (make-semaphore 1)
           (make-semaphore 1)
           #f
           #f
           (dlna-info 'unknown #f #f #f #f
                      0 #f #f #f #f)
           (now-ms)
           0
           (make-hash)
           0
           #t
           #f)])
    (refresh-player! player #:force-volume? #t)
    (set-dlna-player-poll-thread!
     player
     (thread (lambda () (poll-player player))))
    player))

(define (dlna-player-play! player file)
  (check-player 'dlna-player-play! player)
  (let* ([track (player-track-info 'dlna-player-play! player file)]
         [item (publish-track! player track)])
    (with-handlers
        ([exn:fail?
          (lambda (exception)
            (safe-unpublish! player item)
            (raise exception))])
      (call-renderer
       player
       (lambda ()
         (media-renderer-play-uri!
          (dlna-player-renderer player)
          (publication-uri item)
          #:metadata (publication-metadata item))))
      (let ([old-current #f]
            [old-next #f])
        (call-with-semaphore
         (dlna-player-cache-lock player)
         (lambda ()
           (set! old-current (dlna-player-current player))
           (set! old-next (dlna-player-next player))
           (set-dlna-player-current! player item)
           (set-dlna-player-next! player #f)
           (set-dlna-player-cached-info!
            player
            (dlna-info
             'playing
             track
             (publication-uri item)
             #f
             #f
             0
             (dlna-track-info-duration track)
             (dlna-info-volume (dlna-player-cached-info player))
             (dlna-info-muted? (dlna-player-cached-info player))
             #t))
           (set-dlna-player-position-stamp! player (now-ms))))
        (safe-unpublish! player old-current)
        (safe-unpublish! player old-next))
      (void))))

(define (dlna-player-set-next-file! player file)
  (check-player 'dlna-player-set-next-file! player)
  (let* ([track
          (player-track-info
           'dlna-player-set-next-file!
           player
           file)]
         [item (publish-track! player track)])
    (with-handlers
        ([exn:fail?
          (lambda (exception)
            (safe-unpublish! player item)
            (raise exception))])
      (call-renderer
       player
       (lambda ()
         (media-renderer-set-next-uri!
          (dlna-player-renderer player)
          (publication-uri item)
          #:metadata (publication-metadata item))))
      (let ([old-next #f])
        (call-with-semaphore
         (dlna-player-cache-lock player)
         (lambda ()
           (set! old-next (dlna-player-next player))
           (set-dlna-player-next! player item)
           (set-dlna-player-cached-info!
            player
            (struct-copy
             dlna-info
             (dlna-player-cached-info player)
             [next-track track]
             [next-uri (publication-uri item)]))))
        (safe-unpublish! player old-next))
      (void))))

(define (dlna-player-pause! player)
  (check-player 'dlna-player-pause! player)
  (let ([position (dlna-info-position (estimated-info player))])
    (call-renderer
     player
     (lambda ()
       (media-renderer-pause! (dlna-player-renderer player))))
    (update-cache!
     player
     (lambda (info)
       (struct-copy dlna-info
                    info
                    [state 'paused]
                    [position position]))
     #:position? #t)
    (void)))

(define (dlna-player-resume! player)
  (check-player 'dlna-player-resume! player)
  (call-renderer
   player
   (lambda ()
     (media-renderer-play! (dlna-player-renderer player))))
  (update-cache!
   player
   (lambda (info)
     (struct-copy dlna-info info [state 'playing]))
   #:position? #t)
  (void))

(define (dlna-player-stop! player)
  (check-player 'dlna-player-stop! player)
  (call-renderer
   player
   (lambda ()
     (media-renderer-stop! (dlna-player-renderer player))))
  (update-cache!
   player
   (lambda (info)
     (struct-copy dlna-info
                  info
                  [state 'stopped]
                  [position 0]))
   #:position? #t)
  (void))

(define (dlna-player-seek! player seconds)
  (check-player 'dlna-player-seek! player)
  (unless (and (rational? seconds) (not (negative? seconds)))
    (raise-argument-error 'dlna-player-seek!
                          "nonnegative-real?"
                          seconds))
  (call-renderer
   player
   (lambda ()
     (media-renderer-seek!
      (dlna-player-renderer player)
      seconds)))
  (update-cache!
   player
   (lambda (info)
     (struct-copy dlna-info info [position seconds]))
   #:position? #t)
  (void))

(define (dlna-player-seek-percentage! player percentage)
  (check-player 'dlna-player-seek-percentage! player)
  (unless (rational? percentage)
    (raise-argument-error 'dlna-player-seek-percentage!
                          "real?"
                          percentage))
  (let* ([initial (dlna-player-info player)]
         [info
          (if (number? (dlna-info-duration initial))
              initial
              (dlna-player-info player #:refresh? #t))]
         [duration (dlna-info-duration info)])
    (unless (and (number? duration) (positive? duration))
      (raise-arguments-error
       'dlna-player-seek-percentage!
       "track duration is not available"))
    (dlna-player-seek!
     player
     (* duration (/ (min 100 (max 0 percentage)) 100.0)))))

(define (dlna-player-volume! player percentage)
  (check-player 'dlna-player-volume! player)
  (unless (rational? percentage)
    (raise-argument-error 'dlna-player-volume! "real?" percentage))
  (let ([volume
         (min 100
              (max 0
                   (inexact->exact (round percentage))))])
    (call-renderer
     player
     (lambda ()
       (media-renderer-set-volume!
        (dlna-player-renderer player)
        volume)))
    (update-cache!
     player
     (lambda (info)
       (struct-copy dlna-info info [volume volume])))
    (call-with-semaphore
     (dlna-player-cache-lock player)
     (lambda ()
       (set-dlna-player-volume-stamp! player (now-ms))))
    (void)))

(define (dlna-player-muted! player muted?)
  (check-player 'dlna-player-muted! player)
  (unless (boolean? muted?)
    (raise-argument-error 'dlna-player-muted! "boolean?" muted?))
  (call-renderer
   player
   (lambda ()
     (media-renderer-set-muted!
      (dlna-player-renderer player)
      muted?)))
  (update-cache!
   player
   (lambda (info)
     (struct-copy dlna-info info [muted? muted?])))
  (void))

(define (dlna-player-info player #:refresh? [refresh? #f])
  (check-player 'dlna-player-info player)
  (unless (boolean? refresh?)
    (raise-argument-error 'dlna-player-info "boolean?" refresh?))
  (when refresh?
    (refresh-player! player #:force-volume? #t))
  (estimated-info player))

(define (dlna-player-close! player)
  (unless (dlna-player? player)
    (raise-argument-error 'dlna-player-close! "dlna-player?" player))
  (when (dlna-player-running? player)
    (set-dlna-player-running?! player #f)
    (let ([poll-thread (dlna-player-poll-thread player)])
      (when poll-thread
        (kill-thread poll-thread)
        (set-dlna-player-poll-thread! player #f)))
    (with-handlers ([exn:fail? (lambda (_) (void))])
      (call-with-semaphore
       (dlna-player-transport-lock player)
       (lambda ()
         (media-renderer-stop! (dlna-player-renderer player)))))
    (let ([current (dlna-player-current player)]
          [next (dlna-player-next player)])
      (safe-unpublish! player current)
      (safe-unpublish! player next)
      (set-dlna-player-current! player #f)
      (set-dlna-player-next! player #f))
    (media-file-server-stop! (dlna-player-server player)))
  (void))