refactoring
This commit is contained in:
+320
-212
@@ -43,81 +43,107 @@
|
||||
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)
|
||||
(or (and (member state '(playing starting paused)) #t)
|
||||
(and (number? position) (> position 0))))
|
||||
(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)
|
||||
(and (valid-index? playback index)
|
||||
(list-ref (current-tracks 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)
|
||||
(and first
|
||||
second
|
||||
((if (eq? (system-type 'os) 'windows)
|
||||
string-ci=?
|
||||
string=?)
|
||||
(normalized-file first)
|
||||
(normalized-file second))))
|
||||
|
||||
(define (next-index playback index)
|
||||
(define 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)))
|
||||
|
||||
(define (track-index-for-info playback info)
|
||||
(define info-track (dlna-info-track info))
|
||||
(define file (and info-track (dlna-track-info-file info-track)))
|
||||
(define prepared (dlna-playback-prepared-index playback))
|
||||
(cond
|
||||
((and (valid-index? playback prepared)
|
||||
(same-file? file (track-file (track-at playback prepared))))
|
||||
prepared)
|
||||
((eq? first #f) #f)
|
||||
((eq? second #f) #f)
|
||||
(else
|
||||
(for/first ((item (in-list (current-tracks playback)))
|
||||
(index (in-naturals))
|
||||
#:when (same-file? file (track-file item)))
|
||||
index))))
|
||||
(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)
|
||||
@@ -126,159 +152,169 @@
|
||||
(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)
|
||||
(define current (dlna-playback-current-index playback))
|
||||
(when (valid-index? playback current)
|
||||
(define following (next-index playback current))
|
||||
(cond
|
||||
((not following)
|
||||
(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))))))
|
||||
(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)
|
||||
(define 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))
|
||||
(define 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)))
|
||||
(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)
|
||||
(define 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)))
|
||||
(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)
|
||||
(define current (dlna-playback-current-index playback))
|
||||
(define following (and (valid-index? playback current)
|
||||
(next-index playback current)))
|
||||
(if following
|
||||
(play-index/locked! playback following)
|
||||
(begin
|
||||
(dlna-player-stop! (dlna-playback-player playback))
|
||||
(notify! playback
|
||||
'stopped
|
||||
(dlna-player-info (dlna-playback-player 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))))
|
||||
|
||||
(define (poll/locked! playback)
|
||||
(define info (dlna-player-info (dlna-playback-player playback)))
|
||||
(cond
|
||||
((not (dlna-info-reachable? info))
|
||||
(when (dlna-playback-reachable? playback)
|
||||
(set-dlna-playback-reachable?! playback #f)
|
||||
((dlna-playback-error playback) "De DLNA-renderer is niet bereikbaar")))
|
||||
(else
|
||||
(set-dlna-playback-reachable?! playback #t)
|
||||
(define state (normalize-state (dlna-info-state info)))
|
||||
(define uri (dlna-info-uri info))
|
||||
(define position (dlna-info-position info))
|
||||
(define failed-now? #f)
|
||||
|
||||
(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))
|
||||
|
||||
(when (and (dlna-playback-playing-seen? playback)
|
||||
(not (dlna-playback-progress-seen? playback))
|
||||
(dlna-playback-play-request-ms playback)
|
||||
(>= (- (now-ms)
|
||||
(dlna-playback-play-request-ms playback))
|
||||
playback-start-timeout-ms))
|
||||
(set! failed-now? #t)
|
||||
(warn-web-player-dlna
|
||||
"DLNA start was not confirmed: state=~a position=~a uri=~a"
|
||||
state position (or uri ""))
|
||||
(report-failure!
|
||||
playback
|
||||
"De DLNA-renderer bevestigde de start van de track niet"))
|
||||
|
||||
(unless (or failed-now? (dlna-playback-failure-active? playback))
|
||||
;;; 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
|
||||
((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))
|
||||
(cond
|
||||
((and (not (dlna-playback-progress-seen? playback))
|
||||
(dlna-playback-play-request-ms playback)
|
||||
(< (- (now-ms)
|
||||
(dlna-playback-play-request-ms playback))
|
||||
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
|
||||
"De DLNA-renderer bevestigde de start van de track niet"))
|
||||
(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 following poll.
|
||||
(when (or (not (dlna-playback-prepared-index playback))
|
||||
(> (dlna-playback-stopped-polls playback) 1))
|
||||
(set-dlna-playback-playing-seen?! playback #f)
|
||||
(set-dlna-playback-stopped-polls! playback 0)
|
||||
(advance! playback)))))))
|
||||
((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))))
|
||||
|
||||
(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)
|
||||
@@ -293,12 +329,21 @@
|
||||
(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
|
||||
@@ -306,21 +351,34 @@
|
||||
error
|
||||
#:media-file-server media-server
|
||||
#:poll-seconds [poll-seconds 1])
|
||||
(define raw
|
||||
(make-dlna-player device
|
||||
#:media-file-server media-server))
|
||||
(define 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)
|
||||
(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
|
||||
@@ -328,6 +386,13 @@
|
||||
(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
|
||||
@@ -335,6 +400,13 @@
|
||||
(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
|
||||
@@ -348,6 +420,13 @@
|
||||
(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
|
||||
@@ -355,21 +434,35 @@
|
||||
(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.
|
||||
(define info (dlna-player-info (dlna-playback-player playback)))
|
||||
(notify! playback
|
||||
(normalize-state (dlna-info-state info))
|
||||
info))))
|
||||
(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)
|
||||
(define info (dlna-player-info (dlna-playback-player playback)))
|
||||
(notify! playback
|
||||
(normalize-state (dlna-info-state info))
|
||||
info))))
|
||||
(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
|
||||
@@ -378,17 +471,28 @@
|
||||
(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)
|
||||
(define 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))))))
|
||||
(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)
|
||||
@@ -411,17 +515,21 @@
|
||||
(set-dlna-playback-repeat! playback 'one)
|
||||
(check-equal? (next-index playback 1) 1)
|
||||
|
||||
(set-dlna-playback-prepared-index! playback 1)
|
||||
(check-equal?
|
||||
(track-index-for-info
|
||||
playback
|
||||
(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))
|
||||
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))
|
||||
|
||||
+234
-105
@@ -45,19 +45,25 @@
|
||||
"folder.jpg" "folder.jpeg" "folder.png"
|
||||
"front.jpg" "front.jpeg" "front.png"))
|
||||
|
||||
;;; Checks whether a path has an extension supported by racket-audio.
|
||||
(define (audio-file? file)
|
||||
(let ((extension (path-get-extension file)))
|
||||
(and extension
|
||||
(member (string-downcase
|
||||
(string-trim
|
||||
(bytes->string/utf-8 extension)
|
||||
"."))
|
||||
supported-extensions)
|
||||
#t)))
|
||||
(if (eq? extension #f)
|
||||
#f
|
||||
(let ((extension-name
|
||||
(string-downcase
|
||||
(string-trim
|
||||
(bytes->string/utf-8 extension)
|
||||
"."))))
|
||||
(if (member extension-name supported-extensions)
|
||||
#t
|
||||
#f)))))
|
||||
|
||||
;;; Checks whether the final path element starts with a dot.
|
||||
(define (hidden-name? path)
|
||||
(string-prefix? (path->string path) "."))
|
||||
|
||||
;;; Derives a fallback track title from the file name without its extension.
|
||||
(define (file-title file)
|
||||
(let* ((name (file-name-from-path file))
|
||||
(without-extension
|
||||
@@ -66,12 +72,15 @@
|
||||
file)))
|
||||
(path->string without-extension)))
|
||||
|
||||
;;; Returns a non-empty string value or the supplied fallback.
|
||||
(define (nonempty value fallback)
|
||||
(if (and (string? value)
|
||||
(not (string=? (string-trim value) "")))
|
||||
value
|
||||
fallback))
|
||||
|
||||
;;; Reads audio metadata and converts a file path to a track value.
|
||||
;;; File-name and MIME-type fallbacks are used when metadata cannot be read.
|
||||
(define (path->track file)
|
||||
(let ((fallback-title (file-title file)))
|
||||
(with-handlers
|
||||
@@ -95,6 +104,7 @@
|
||||
(track file fallback-title "" "" #f
|
||||
(mimetype-for-ext file))))))))
|
||||
|
||||
;;; Builds the filesystem path represented by a library-relative path.
|
||||
(define (library-path library relative-path)
|
||||
(if (null? relative-path)
|
||||
(music-library-root library)
|
||||
@@ -102,6 +112,7 @@
|
||||
(music-library-root library)
|
||||
relative-path)))
|
||||
|
||||
;;; Classifies a path as a container, supported track or unusable entry.
|
||||
(define (path-kind path)
|
||||
(cond
|
||||
((directory-exists? path) 'container)
|
||||
@@ -110,6 +121,7 @@
|
||||
'track)
|
||||
(else #f)))
|
||||
|
||||
;;; Orders browser entries with containers first and names alphabetically.
|
||||
(define (entry<? first second)
|
||||
(cond
|
||||
((and (eq? (browser-entry-kind first) 'container)
|
||||
@@ -122,6 +134,7 @@
|
||||
(string-ci<? (browser-entry-name first)
|
||||
(browser-entry-name second)))))
|
||||
|
||||
;;; Recursively converts the browsable contents of a directory to tracks.
|
||||
(define (directory-tracks library relative-path)
|
||||
(append-map
|
||||
(λ (entry)
|
||||
@@ -134,126 +147,196 @@
|
||||
(browser-entry-relative-path entry))))))
|
||||
(browse-library library relative-path)))
|
||||
|
||||
(define (library-contains-audio-file? libraries file)
|
||||
(and (path-string? file)
|
||||
(file-exists? file)
|
||||
(audio-file? file)
|
||||
(let ((full-file
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(simplify-path (path->complete-path file) #t))))
|
||||
(and full-file
|
||||
(for/or ((library (in-list libraries)))
|
||||
(define root
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(simplify-path
|
||||
(path->complete-path (music-library-root library))
|
||||
#t)))
|
||||
(and root
|
||||
(let ((relative (find-relative-path root full-file)))
|
||||
(and (relative-path? relative)
|
||||
(not (member 'up (explode-path relative)))))))))))
|
||||
;;; Produces a resolved complete path, or #f when resolution fails.
|
||||
(define (complete-path/safe path)
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(simplify-path (path->complete-path path) #t)))
|
||||
|
||||
;;; Checks whether file is located below root without traversing upward.
|
||||
(define (path-below-root? root file)
|
||||
(let* ((relative (find-relative-path root file))
|
||||
(elements (explode-path relative)))
|
||||
(and (relative-path? relative)
|
||||
(not (member 'up elements)))))
|
||||
|
||||
;;; Recognizes a library specification containing a display name and path.
|
||||
(define (named-library-specification? specification)
|
||||
(and (list? specification)
|
||||
(= (length specification) 2)
|
||||
(string? (car specification))
|
||||
(path-string? (cadr specification))))
|
||||
|
||||
;;; Extracts the optional display name and path from a library specification.
|
||||
(define (specification-values specification)
|
||||
(cond
|
||||
((named-library-specification? specification)
|
||||
(values (string-trim (car specification))
|
||||
(cadr specification)))
|
||||
((path-string? specification)
|
||||
(values #f specification))
|
||||
(else
|
||||
(raise-argument-error
|
||||
'make-music-libraries
|
||||
"(or/c path-string? (list/c string? path-string?))"
|
||||
specification))))
|
||||
|
||||
;;; Reads embedded ID3 artwork from a track, returning #f when unavailable.
|
||||
(define (embedded-artwork item)
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(call-with-id3-tags
|
||||
(track-file item)
|
||||
(λ (tags)
|
||||
(if (not (tags-valid? tags))
|
||||
#f
|
||||
(let ((picture (tags-picture tags)))
|
||||
(if (eq? picture #f)
|
||||
#f
|
||||
(let ((mime (id3-picture-mimetype picture)))
|
||||
(artwork
|
||||
(if (and (string? mime)
|
||||
(not (string=? mime "")))
|
||||
mime
|
||||
"application/octet-stream")
|
||||
(id3-picture-bytes picture))))))))))
|
||||
|
||||
;;; Checks whether a path names an existing conventional cover image.
|
||||
(define (cover-file? candidate)
|
||||
(let ((name (file-name-from-path candidate)))
|
||||
(cond
|
||||
((eq? name #f) #f)
|
||||
((not (file-exists? candidate)) #f)
|
||||
((member (path->string name)
|
||||
cover-file-names
|
||||
string-ci=?) #t)
|
||||
(else #f))))
|
||||
|
||||
;;; Searches the track directory for a conventional cover image.
|
||||
(define (cover-artwork item)
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(let* ((track-directory (path-only (track-file item)))
|
||||
(directory (if (eq? track-directory #f)
|
||||
(current-directory)
|
||||
track-directory))
|
||||
(cover (findf cover-file?
|
||||
(directory-list directory #:build? #t))))
|
||||
(if (eq? cover #f)
|
||||
#f
|
||||
(let ((mime (mimetype-for-ext cover)))
|
||||
(artwork (if (string? mime)
|
||||
mime
|
||||
"application/octet-stream")
|
||||
(file->bytes cover)))))))
|
||||
|
||||
;;; Validates one normalized library root and constructs its public value.
|
||||
(define (named-root->music-library named-root index)
|
||||
(let ((configured-name (car named-root))
|
||||
(root (cadr named-root)))
|
||||
(unless (directory-exists? root)
|
||||
(raise-arguments-error
|
||||
'make-music-libraries
|
||||
"music library is not an existing directory"
|
||||
"path" root))
|
||||
(let* ((name (file-name-from-path root))
|
||||
(default-name (if (eq? name #f)
|
||||
(path->string root)
|
||||
(path->string name))))
|
||||
(music-library
|
||||
(format "library-~a" index)
|
||||
(cond
|
||||
((eq? configured-name #f) default-name)
|
||||
((string=? configured-name "") default-name)
|
||||
(else configured-name))
|
||||
root))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether a supported audio file belongs to a music library.
|
||||
; pre : Libraries contains music-library values; file may be any value.
|
||||
; post : The file system remains unchanged.
|
||||
; result : #t when file exists below a configured root, otherwise #f.
|
||||
; internals: audio-file? first rejects unsupported files. complete-path/safe
|
||||
; resolves the candidate and each library root. The named loop calls
|
||||
; path-below-root? until one root contains the file; that helper uses
|
||||
; find-relative-path and rejects paths containing an 'up element.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (library-contains-audio-file? libraries file)
|
||||
(cond
|
||||
((not (path-string? file)) #f)
|
||||
((not (file-exists? file)) #f)
|
||||
((not (audio-file? file)) #f)
|
||||
(else
|
||||
(let ((full-file (complete-path/safe file)))
|
||||
(if (eq? full-file #f)
|
||||
#f
|
||||
(let loop ((remaining libraries))
|
||||
(if (null? remaining)
|
||||
#f
|
||||
(let ((root
|
||||
(complete-path/safe
|
||||
(music-library-root (car remaining)))))
|
||||
(cond
|
||||
((eq? root #f)
|
||||
(loop (cdr remaining)))
|
||||
((path-below-root? root full-file) #t)
|
||||
(else
|
||||
(loop (cdr remaining))))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Turn configured directory paths into music libraries.
|
||||
; pre : Every value is a path or a (display-name path) list.
|
||||
; post : No directory contents or audio metadata have been read.
|
||||
; result : Libraries in configuration order, without duplicate roots.
|
||||
; internals: specification-values separates each optional name from its path.
|
||||
; map normalizes the paths and remove-duplicates compares their
|
||||
; roots. The named loop calls named-root->music-library to validate
|
||||
; each directory and assign its sequential library id.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (make-music-libraries specifications)
|
||||
(define (specification-values specification)
|
||||
(if (and (list? specification)
|
||||
(= (length specification) 2)
|
||||
(string? (car specification))
|
||||
(path-string? (cadr specification)))
|
||||
(values (string-trim (car specification))
|
||||
(cadr specification))
|
||||
(if (path-string? specification)
|
||||
(values #f specification)
|
||||
(raise-argument-error
|
||||
'make-music-libraries
|
||||
"(or/c path-string? (list/c string? path-string?))"
|
||||
specification))))
|
||||
(let ((roots
|
||||
(remove-duplicates
|
||||
(for/list ((specification (in-list specifications)))
|
||||
(let-values (((name path)
|
||||
(specification-values specification)))
|
||||
(list name
|
||||
(normal-case-path
|
||||
(path->complete-path path)))))
|
||||
(map (λ (specification)
|
||||
(let-values (((name path)
|
||||
(specification-values specification)))
|
||||
(list name
|
||||
(normal-case-path
|
||||
(path->complete-path path)))))
|
||||
specifications)
|
||||
(λ (first second)
|
||||
(equal? (cadr first) (cadr second))))))
|
||||
(for/list ((named-root (in-list roots))
|
||||
(index (in-naturals)))
|
||||
(define configured-name (car named-root))
|
||||
(define root (cadr named-root))
|
||||
(unless (directory-exists? root)
|
||||
(raise-arguments-error
|
||||
'make-music-libraries
|
||||
"music library is not an existing directory"
|
||||
"path" root))
|
||||
(let ((name (file-name-from-path root)))
|
||||
(music-library
|
||||
(format "library-~a" index)
|
||||
(if (and configured-name
|
||||
(not (string=? configured-name "")))
|
||||
configured-name
|
||||
(if name
|
||||
(path->string name)
|
||||
(path->string root)))
|
||||
root)))))
|
||||
(let loop ((remaining roots)
|
||||
(index 0))
|
||||
(if (null? remaining)
|
||||
'()
|
||||
(cons (named-root->music-library (car remaining) index)
|
||||
(loop (cdr remaining) (add1 index)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the artwork associated with a track.
|
||||
; pre : Item names a local audio file.
|
||||
; post : The audio file and optional neighbouring image remain unchanged.
|
||||
; result : Embedded artwork, a conventional folder cover, or #f.
|
||||
; internals: embedded-artwork first reads the picture stored in the audio tags.
|
||||
; Only when that returns #f does cover-artwork search the track's
|
||||
; directory for one of the names in cover-file-names.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (track-artwork item)
|
||||
(define embedded
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(call-with-id3-tags
|
||||
(track-file item)
|
||||
(λ (tags)
|
||||
(let ((picture (and (tags-valid? tags)
|
||||
(tags-picture tags))))
|
||||
(and picture
|
||||
(artwork (let ((mime (id3-picture-mimetype picture)))
|
||||
(if (and (string? mime)
|
||||
(not (string=? mime "")))
|
||||
mime
|
||||
"application/octet-stream"))
|
||||
(id3-picture-bytes picture))))))))
|
||||
(or embedded
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(let* ((directory (or (path-only (track-file item))
|
||||
(current-directory)))
|
||||
(cover
|
||||
(findf
|
||||
(λ (candidate)
|
||||
(let ((name (file-name-from-path candidate)))
|
||||
(and name
|
||||
(file-exists? candidate)
|
||||
(member (path->string name)
|
||||
cover-file-names
|
||||
string-ci=?))))
|
||||
(directory-list directory #:build? #t))))
|
||||
(and cover
|
||||
(let ((mime (mimetype-for-ext cover)))
|
||||
(artwork (if (string? mime)
|
||||
mime
|
||||
"application/octet-stream")
|
||||
(file->bytes cover))))))))
|
||||
(let ((embedded (embedded-artwork item)))
|
||||
(if (eq? embedded #f)
|
||||
(cover-artwork item)
|
||||
embedded)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List the immediate folders and supported audio files in a library.
|
||||
; pre : Relative-path was produced by a previous browse result.
|
||||
; post : Child directories are listed before tracks; metadata is not read.
|
||||
; result : Browser entries for one directory level.
|
||||
; internals: library-path resolves the requested directory. directory-list and
|
||||
; path-kind supply filter-map with usable children; hidden-name?
|
||||
; removes hidden containers. sort uses entry<? to put containers
|
||||
; first and compare names without regard to case.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (browse-library library relative-path)
|
||||
(let ((path (library-path library relative-path)))
|
||||
@@ -267,13 +350,20 @@
|
||||
(λ (name)
|
||||
(let* ((full-path (build-path path name))
|
||||
(kind (path-kind full-path)))
|
||||
(and kind
|
||||
(not (and (eq? kind 'container)
|
||||
(hidden-name? name)))
|
||||
(browser-entry
|
||||
(path->string name)
|
||||
kind
|
||||
(append relative-path (list name))))))
|
||||
(cond
|
||||
((eq? kind #f) #f)
|
||||
((eq? kind 'container)
|
||||
(if (hidden-name? name)
|
||||
#f
|
||||
(browser-entry
|
||||
(path->string name)
|
||||
kind
|
||||
(append relative-path (list name)))))
|
||||
(else
|
||||
(browser-entry
|
||||
(path->string name)
|
||||
kind
|
||||
(append relative-path (list name)))))))
|
||||
(directory-list path))
|
||||
entry<?)))
|
||||
|
||||
@@ -282,6 +372,9 @@
|
||||
; pre : Entry belongs to library and was produced by browse-library.
|
||||
; post : Track metadata is read; containers are traversed recursively.
|
||||
; result : One track, or all supported tracks below the selected container.
|
||||
; internals: A track entry is resolved by library-path and read by path->track.
|
||||
; A container is passed to directory-tracks, which recursively calls
|
||||
; browse-library and path->track in browser sort order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (browser-entry->tracks library entry)
|
||||
(if (eq? (browser-entry-kind entry) 'container)
|
||||
@@ -292,18 +385,30 @@
|
||||
(library-path library
|
||||
(browser-entry-relative-path entry))))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tests for module library.rkt
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define root
|
||||
(make-temporary-file "rkt-web-library-~a" 'directory))
|
||||
|
||||
(define outside-file
|
||||
(make-temporary-file "rkt-web-outside-~a.mp3"))
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(make-directory (build-path root "Album"))
|
||||
(make-directory (build-path root ".Hidden"))
|
||||
(call-with-output-file
|
||||
(build-path root "Album" "inside.mp3") void)
|
||||
(call-with-output-file (build-path root "track.mp3") void)
|
||||
(call-with-output-file (build-path root "cover.jpg") void)
|
||||
(call-with-output-file (build-path root "ignored.txt") void)
|
||||
(let* ((libraries (make-music-libraries (list root)))
|
||||
(entries (browse-library (car libraries) '())))
|
||||
(check-equal? (length libraries) 1)
|
||||
@@ -312,6 +417,29 @@
|
||||
(check-eq? (browser-entry-kind (car entries)) 'container)
|
||||
(check-equal? (browser-entry-name (cadr entries)) "track.mp3")
|
||||
(check-eq? (browser-entry-kind (cadr entries)) 'track)
|
||||
(check-equal?
|
||||
(length
|
||||
(browser-entry->tracks (car libraries) (car entries)))
|
||||
1)
|
||||
(check-true
|
||||
(library-contains-audio-file?
|
||||
libraries
|
||||
(build-path root "track.mp3")))
|
||||
(check-true
|
||||
(library-contains-audio-file?
|
||||
libraries
|
||||
(build-path root "Album" "inside.mp3")))
|
||||
(check-false
|
||||
(library-contains-audio-file?
|
||||
libraries
|
||||
(build-path root "cover.jpg")))
|
||||
(check-false
|
||||
(library-contains-audio-file?
|
||||
libraries
|
||||
outside-file))
|
||||
(check-equal?
|
||||
(length (make-music-libraries (list root root)))
|
||||
1)
|
||||
(check-equal?
|
||||
(music-library-name
|
||||
(car (make-music-libraries
|
||||
@@ -324,4 +452,5 @@
|
||||
"Track" "" "" #f "audio/mpeg")))
|
||||
"image/jpeg")))
|
||||
(λ ()
|
||||
(delete-directory/files root))))
|
||||
(delete-directory/files root)
|
||||
(delete-file outside-file))))
|
||||
|
||||
@@ -1,110 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require file/sha1
|
||||
racket/contract
|
||||
racket/os
|
||||
racket/path
|
||||
racket/random
|
||||
racket/string
|
||||
simple-ini)
|
||||
|
||||
(provide (struct-out player-agent-config)
|
||||
load-player-agent-config
|
||||
save-player-agent-config!
|
||||
valid-app-id?)
|
||||
|
||||
(struct player-agent-config (file ini app-id server-url name) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (fresh-app-id)
|
||||
(bytes->hex-string (crypto-random-bytes 32)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Recognize a playback-agent application identifier.
|
||||
; pre : value is any Racket value.
|
||||
; post : No state is changed.
|
||||
; result : #t only for a 256-bit identifier encoded as 64 hexadecimal digits.
|
||||
; internals:
|
||||
; Identifiers are accepted case-insensitively and normalized while
|
||||
; loading configuration.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (valid-app-id? value)
|
||||
(-> any/c boolean?)
|
||||
(and (string? value)
|
||||
(regexp-match? #px"^[0-9a-fA-F]{64}$" value)
|
||||
#t))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Load the playback-agent INI configuration.
|
||||
; pre : file is a writable path-string understood by simple-ini.
|
||||
; post : Missing defaults and a generated application ID are persisted.
|
||||
; result : A player-agent-config value containing normalized settings.
|
||||
; internals:
|
||||
; Reusing the stored application ID preserves the server allowlist;
|
||||
; only a missing or malformed identifier is replaced.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (load-player-agent-config
|
||||
[file (get-ini-file 'rkt-web-player-agent)])
|
||||
(->* () (path-string?) player-agent-config?)
|
||||
(let* ((ini (file->ini file))
|
||||
(configured-id (ini-get ini 'agent 'app-id #f))
|
||||
(value
|
||||
(player-agent-config
|
||||
file
|
||||
ini
|
||||
(if (valid-app-id? configured-id)
|
||||
(string-downcase configured-id)
|
||||
(fresh-app-id))
|
||||
(ini-get ini 'server 'url "http://127.0.0.1:8080")
|
||||
(ini-get ini 'agent 'name
|
||||
(format "~a playback" (gethostname))))))
|
||||
(save-player-agent-config! value)
|
||||
value))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Persist a playback-agent configuration.
|
||||
; pre : value is a player-agent-config with a writable file path.
|
||||
; post : Its ID, name and server URL are stored in a private INI file.
|
||||
; result : The result returned by simple-ini's ini->file procedure.
|
||||
; internals:
|
||||
; The existing parsed INI value is updated directly so unrelated
|
||||
; settings remain intact.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (save-player-agent-config! value)
|
||||
(-> player-agent-config? void?)
|
||||
(let ((ini (player-agent-config-ini value)))
|
||||
(ini-set! ini 'agent 'app-id (player-agent-config-app-id value))
|
||||
(ini-set! ini 'agent 'name (player-agent-config-name value))
|
||||
(ini-set! ini 'server 'url (player-agent-config-server-url value))
|
||||
(ini->file ini (player-agent-config-file value) #:private? #t)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
racket/file)
|
||||
|
||||
(define test-directory (make-temporary-file "rkt-agent-config-~a" 'directory))
|
||||
(define test-file (build-path test-directory "agent.ini"))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(let* ((first (load-player-agent-config test-file))
|
||||
(changed
|
||||
(struct-copy player-agent-config first
|
||||
(server-url "https://music.example.test")
|
||||
(name "Test output"))))
|
||||
(check-true (valid-app-id? (player-agent-config-app-id first)))
|
||||
(save-player-agent-config! changed)
|
||||
(let ((second (load-player-agent-config test-file)))
|
||||
(check-equal? (player-agent-config-app-id second)
|
||||
(player-agent-config-app-id first))
|
||||
(check-equal? (player-agent-config-server-url second)
|
||||
"https://music.example.test")
|
||||
(check-equal? (player-agent-config-name second) "Test output"))))
|
||||
(λ () (delete-directory/files test-directory))))
|
||||
@@ -1,461 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require json
|
||||
net/url
|
||||
racket-audio
|
||||
racket/contract
|
||||
racket/file
|
||||
racket/path
|
||||
racket/port
|
||||
racket/string
|
||||
simple-log
|
||||
"translate.rkt")
|
||||
|
||||
(provide (struct-out player-agent-runtime)
|
||||
make-player-agent-runtime)
|
||||
|
||||
(sl-def-log player-agent)
|
||||
|
||||
(struct exn:fail:agent-denied exn:fail () #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Expose the small procedure-based interface of a running agent.
|
||||
; pre : Constructor fields are lifecycle/query procedures and a stable ID.
|
||||
; post : Creating or recognizing a value changes no external state.
|
||||
; result : player-agent-runtime? recognizes values returned by the factory.
|
||||
; internals:
|
||||
; Procedures keep the mutable audio and polling state private without
|
||||
; introducing a class or a second generic backend abstraction.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(struct player-agent-runtime
|
||||
(start! reconnect! shutdown! snapshot current-track running? app-id)
|
||||
#:transparent)
|
||||
|
||||
(define (base-url value)
|
||||
(string->url
|
||||
(regexp-replace #px"/+$" (string-trim value) "")))
|
||||
|
||||
(define (endpoint-url base path)
|
||||
(combine-url/relative (base-url base) path))
|
||||
|
||||
(define (post-json base path data)
|
||||
(let ((input
|
||||
(post-pure-port
|
||||
(endpoint-url base path)
|
||||
(jsexpr->bytes data)
|
||||
(list "Content-Type: application/json"
|
||||
"Cache-Control: no-store"))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(let ((response (read-json input)))
|
||||
(when (and (hash? response)
|
||||
(string? (hash-ref response 'error #f)))
|
||||
(if (equal? (hash-ref response 'code #f)
|
||||
"agent-not-authorized")
|
||||
(raise
|
||||
(exn:fail:agent-denied
|
||||
(hash-ref response 'error)
|
||||
(current-continuation-marks)))
|
||||
(error 'player-agent (hash-ref response 'error))))
|
||||
response))
|
||||
(λ () (close-input-port input)))))
|
||||
|
||||
(define (normal-state state)
|
||||
(cond
|
||||
((memq state '(initialized no-media)) "stopped")
|
||||
((eq? state 'transitioning) "starting")
|
||||
(else (symbol->string state))))
|
||||
|
||||
(define (safe-delete-file file)
|
||||
(when (and file (file-exists? file))
|
||||
(with-handlers ((exn:fail?
|
||||
(λ (exception)
|
||||
(warn-player-agent
|
||||
"Could not remove temporary media file ~a: ~a"
|
||||
file
|
||||
(exn-message exception)))))
|
||||
(delete-file file))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create the headless polling and audio runtime for one agent.
|
||||
; pre : Server URL, display name and application ID are strings; callbacks
|
||||
; accept the status/denial messages supplied to them.
|
||||
; post : Mutable state is initialized but no worker thread or audio backend
|
||||
; is started until the returned start! procedure is called.
|
||||
; result : A player-agent-runtime containing its lifecycle/query procedures.
|
||||
; internals:
|
||||
; One closure owns the simple mutable state shared by polling,
|
||||
; command and audio callbacks. Keeping these procedures together
|
||||
; makes their synchronization and cleanup order directly visible.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (make-player-agent-runtime initial-server-url
|
||||
initial-name
|
||||
app-id
|
||||
#:status-callback
|
||||
[status-callback void]
|
||||
#:denied-callback
|
||||
[denied-callback void])
|
||||
(->* (string? string? string?)
|
||||
(#:status-callback (-> string? any/c)
|
||||
#:denied-callback (-> string? any/c))
|
||||
player-agent-runtime?)
|
||||
(let* ((server-url initial-server-url)
|
||||
(assigned-name initial-name)
|
||||
(state-lock (make-semaphore 1))
|
||||
(worker #f)
|
||||
(command-worker #f)
|
||||
(executing-command-id 0)
|
||||
(running #f)
|
||||
(authorization-notified? #f)
|
||||
(audio #f)
|
||||
(current-media-key #f)
|
||||
(cached-media (make-hash))
|
||||
(prefetched-track #f)
|
||||
(auto-started-key #f)
|
||||
(pending-auto-music-id #f)
|
||||
(music-tracks (make-hash))
|
||||
(current-track-value #f)
|
||||
(acknowledged-command 0)
|
||||
(ended-counter 0)
|
||||
(logical-volume 50)
|
||||
(agent-state
|
||||
(hasheq 'state "stopped"
|
||||
'position 0
|
||||
'duration 'null
|
||||
'rate 'null
|
||||
'channels 'null
|
||||
'bits 'null
|
||||
'format ""
|
||||
'volume logical-volume
|
||||
'error 'null)))
|
||||
|
||||
(define (with-agent-state proc)
|
||||
(call-with-semaphore state-lock proc))
|
||||
|
||||
(define (state-value value fallback)
|
||||
(if (eq? value #f) fallback value))
|
||||
|
||||
(define (snapshot)
|
||||
(with-agent-state (λ () agent-state)))
|
||||
|
||||
(define (current-track)
|
||||
(with-agent-state (λ () current-track-value)))
|
||||
|
||||
(define (set-agent-error! message)
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(set! agent-state (hash-set agent-state 'error message)))))
|
||||
|
||||
(define (clear-agent-error!)
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(set! agent-state (hash-set agent-state 'error 'null)))))
|
||||
|
||||
(define (update-from-audio! state full-state)
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(let ((audible-music-id (hash-ref full-state 'at-music-id #f)))
|
||||
(set! agent-state
|
||||
(hasheq
|
||||
'state (normal-state state)
|
||||
'position (state-value (hash-ref full-state 'at-second #f) 0)
|
||||
'duration (state-value (hash-ref full-state 'duration #f) 'null)
|
||||
'rate (state-value (hash-ref full-state 'rate #f) 'null)
|
||||
'channels (state-value (hash-ref full-state 'channels #f) 'null)
|
||||
'bits (state-value (hash-ref full-state 'bits #f) 'null)
|
||||
'format (let ((decoder (hash-ref full-state 'decoder #f)))
|
||||
(if decoder (format "~a" decoder) ""))
|
||||
'volume logical-volume
|
||||
'error 'null))
|
||||
(when (and pending-auto-music-id
|
||||
(number? audible-music-id)
|
||||
(= pending-auto-music-id audible-music-id))
|
||||
(let ((audible-track
|
||||
(hash-ref music-tracks audible-music-id #f)))
|
||||
(when audible-track
|
||||
(set! current-track-value audible-track)
|
||||
(hash-clear! music-tracks)
|
||||
(hash-set! music-tracks audible-music-id audible-track)))
|
||||
(set! pending-auto-music-id #f)
|
||||
(set! ended-counter (+ ended-counter 1)))))))
|
||||
|
||||
(define (ensure-audio!)
|
||||
(unless audio
|
||||
(set! audio
|
||||
(make-audio-player
|
||||
(λ (_handle state full-state)
|
||||
(update-from-audio! state full-state))
|
||||
(λ (handle)
|
||||
(advance-at-decoder-eof! handle))))
|
||||
(audio-ao-buf-ms! audio 500)
|
||||
(audio-buf-seconds! audio 4 10)
|
||||
(let ((scaled (/ logical-volume 100.0)))
|
||||
(audio-volume! audio (* 100.0 scaled scaled))))
|
||||
audio)
|
||||
|
||||
(define (download-media! token filename)
|
||||
(let* ((extension
|
||||
(or (path-get-extension (string->path filename)) #""))
|
||||
(target
|
||||
(make-temporary-file
|
||||
(string-append "rkt-player-agent-~a"
|
||||
(bytes->string/utf-8 extension))))
|
||||
(path (format "/api/agent/media/~a/~a" app-id token))
|
||||
(input (get-pure-port (endpoint-url server-url path))))
|
||||
(with-handlers ((exn:fail?
|
||||
(λ (exception)
|
||||
(close-input-port input)
|
||||
(safe-delete-file target)
|
||||
(raise exception))))
|
||||
(call-with-output-file
|
||||
target
|
||||
(λ (output) (copy-port input output))
|
||||
#:exists 'truncate/replace)
|
||||
(close-input-port input)
|
||||
target)))
|
||||
|
||||
(define (command-cache-key data)
|
||||
(hash-ref data 'cacheKey (hash-ref data 'mediaToken)))
|
||||
|
||||
(define (ensure-media-cached! data)
|
||||
(let* ((key (command-cache-key data))
|
||||
(found (hash-ref cached-media key #f)))
|
||||
(if (and found (file-exists? found))
|
||||
found
|
||||
(let ((downloaded
|
||||
(download-media!
|
||||
(hash-ref data 'mediaToken)
|
||||
(hash-ref data 'filename "track"))))
|
||||
(hash-set! cached-media key downloaded)
|
||||
downloaded))))
|
||||
|
||||
(define (discard-unused-media! keep-key)
|
||||
(for ((entry (in-list (hash->list cached-media))))
|
||||
(unless (equal? (car entry) keep-key)
|
||||
(safe-delete-file (cdr entry))
|
||||
(hash-remove! cached-media (car entry)))))
|
||||
|
||||
;; Decoder EOF occurs before audible EOF. Queueing the prefetched decoder at
|
||||
;; this point appends it behind racket-audio's remaining output buffer.
|
||||
(define (advance-at-decoder-eof! handle)
|
||||
(let ((prepared
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(let ((value prefetched-track))
|
||||
(set! prefetched-track #f)
|
||||
value)))))
|
||||
(cond
|
||||
(prepared
|
||||
(let* ((data (car prepared))
|
||||
(path (cdr prepared))
|
||||
(key (command-cache-key data)))
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(λ (exception)
|
||||
(warn-player-agent "Could not start prefetched track: ~a"
|
||||
(exn-message exception))
|
||||
(set-agent-error! (exn-message exception))
|
||||
(with-agent-state
|
||||
(λ () (set! ended-counter (+ ended-counter 1)))))))
|
||||
(let ((music-id (audio-play! handle path)))
|
||||
(info-player-agent "Queued prefetched track ~a as music id ~a"
|
||||
(hash-ref data 'filename "track")
|
||||
music-id)
|
||||
(set! current-media-key key)
|
||||
(discard-unused-media! key)
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(hash-set! music-tracks music-id data)
|
||||
(set! auto-started-key key)
|
||||
(set! pending-auto-music-id music-id)))))))
|
||||
(else
|
||||
(warn-player-agent
|
||||
"Decoder reached EOF before the next track was prefetched")
|
||||
(with-agent-state
|
||||
(λ () (set! ended-counter (+ ended-counter 1))))))))
|
||||
|
||||
(define (execute-command! command)
|
||||
(let ((action (hash-ref command 'action ""))
|
||||
(data (hash-ref command 'data (hasheq))))
|
||||
(info-player-agent "Executing command ~a" action)
|
||||
(cond
|
||||
((string=? action "play")
|
||||
(let* ((next-key (command-cache-key data))
|
||||
(already-started?
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(let ((matches?
|
||||
(and auto-started-key
|
||||
(equal? auto-started-key next-key))))
|
||||
(when matches?
|
||||
(set! auto-started-key #f))
|
||||
matches?)))))
|
||||
(with-agent-state
|
||||
(λ () (set! current-track-value data)))
|
||||
(unless already-started?
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(set! prefetched-track #f)
|
||||
(set! auto-started-key #f)
|
||||
(set! pending-auto-music-id #f)
|
||||
(set! agent-state
|
||||
(hash-set
|
||||
(hash-set agent-state 'state "starting")
|
||||
'error 'null))))
|
||||
(let* ((next-media (ensure-media-cached! data))
|
||||
;; audio-play! interrupts and closes the previous decoder.
|
||||
(music-id (audio-play! (ensure-audio!) next-media)))
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(hash-clear! music-tracks)
|
||||
(hash-set! music-tracks music-id data)))
|
||||
(set! current-media-key next-key)
|
||||
(discard-unused-media! next-key)))))
|
||||
((string=? action "prefetch")
|
||||
(let ((key (command-cache-key data))
|
||||
(path (ensure-media-cached! data)))
|
||||
(with-agent-state
|
||||
(λ () (set! prefetched-track (cons data path))))
|
||||
(info-player-agent "Prefetched ~a"
|
||||
(hash-ref data 'filename "track"))
|
||||
(for ((entry (in-list (hash->list cached-media))))
|
||||
(unless (or (equal? (car entry) current-media-key)
|
||||
(equal? (car entry) key))
|
||||
(safe-delete-file (cdr entry))
|
||||
(hash-remove! cached-media (car entry))))))
|
||||
((string=? action "pause")
|
||||
(audio-pause! (ensure-audio!) #t))
|
||||
((string=? action "resume")
|
||||
(audio-pause! (ensure-audio!) #f))
|
||||
((string=? action "stop")
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(set! prefetched-track #f)
|
||||
(set! auto-started-key #f)
|
||||
(set! pending-auto-music-id #f)))
|
||||
(when audio
|
||||
(audio-stop! audio)))
|
||||
((string=? action "seek")
|
||||
(audio-seek! (ensure-audio!) (hash-ref data 'percentage 0)))
|
||||
((string=? action "volume")
|
||||
(set! logical-volume (min 100 (max 0 (hash-ref data 'value 50))))
|
||||
(let ((scaled (/ logical-volume 100.0)))
|
||||
(audio-volume! (ensure-audio!) (* 100.0 scaled scaled)))
|
||||
(with-agent-state
|
||||
(λ ()
|
||||
(set! agent-state
|
||||
(hash-set agent-state 'volume logical-volume)))))
|
||||
(else
|
||||
(error 'player-agent "unknown command: ~a" action)))))
|
||||
|
||||
(define (poll-loop)
|
||||
(with-handlers
|
||||
((exn:fail:agent-denied?
|
||||
(λ (exception)
|
||||
(let ((message (format (tr 'denied-message) app-id)))
|
||||
(warn-player-agent "Agent authorization refused: ~a"
|
||||
(exn-message exception))
|
||||
(set-agent-error! message)
|
||||
(status-callback
|
||||
(tr 'unauthorized-status))
|
||||
(unless authorization-notified?
|
||||
(set! authorization-notified? #t)
|
||||
(denied-callback message))
|
||||
(when running
|
||||
(sleep 3)
|
||||
(poll-loop)))))
|
||||
(exn:fail?
|
||||
(λ (exception)
|
||||
(warn-player-agent "Connection cycle failed: ~a"
|
||||
(exn-message exception))
|
||||
(set-agent-error! (exn-message exception))
|
||||
(status-callback
|
||||
(format (tr 'disconnected) (exn-message exception)))
|
||||
(when running
|
||||
(sleep 3)
|
||||
(poll-loop)))))
|
||||
(post-json server-url
|
||||
"/api/agent/register"
|
||||
(hasheq 'appId app-id 'name assigned-name))
|
||||
(clear-agent-error!)
|
||||
(status-callback (tr 'connected))
|
||||
(info-player-agent "Registered at ~a as ~a" server-url assigned-name)
|
||||
(let loop ()
|
||||
(when running
|
||||
(let* ((response
|
||||
(post-json
|
||||
server-url
|
||||
"/api/agent/poll"
|
||||
(hasheq 'appId app-id
|
||||
'name assigned-name
|
||||
'ack acknowledged-command
|
||||
'endedCounter ended-counter
|
||||
'state (snapshot))))
|
||||
(command (hash-ref response 'command 'null)))
|
||||
(when (and (hash? command)
|
||||
(> (hash-ref command 'id 0) acknowledged-command)
|
||||
(not (= (hash-ref command 'id 0)
|
||||
executing-command-id)))
|
||||
(set! executing-command-id (hash-ref command 'id))
|
||||
(set! command-worker
|
||||
(thread
|
||||
(λ ()
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(λ (exception)
|
||||
(warn-player-agent "Command failed: ~a"
|
||||
(exn-message exception))
|
||||
(set-agent-error! (exn-message exception)))))
|
||||
(clear-agent-error!)
|
||||
(execute-command! command))
|
||||
(set! acknowledged-command (hash-ref command 'id))
|
||||
(set! executing-command-id 0)
|
||||
(set! command-worker #f))))))
|
||||
(sleep 1)
|
||||
(loop)))))
|
||||
|
||||
(define (start!)
|
||||
(unless running
|
||||
(set! running #t)
|
||||
(status-callback (tr 'connecting))
|
||||
(set! worker (thread poll-loop))))
|
||||
|
||||
(define (stop!)
|
||||
(set! running #f)
|
||||
(when (and worker (not (thread-dead? worker)))
|
||||
(kill-thread worker))
|
||||
(when (and command-worker (not (thread-dead? command-worker)))
|
||||
(kill-thread command-worker))
|
||||
(set! worker #f)
|
||||
(set! command-worker #f)
|
||||
(set! executing-command-id 0))
|
||||
|
||||
(define (reconnect! new-server-url new-name)
|
||||
(stop!)
|
||||
(set! authorization-notified? #f)
|
||||
(set! server-url (string-trim new-server-url))
|
||||
(set! assigned-name (string-trim new-name))
|
||||
(start!))
|
||||
|
||||
(define (shutdown!)
|
||||
(stop!)
|
||||
(when audio
|
||||
(with-handlers ((exn:fail? void))
|
||||
(audio-quit! audio))
|
||||
(set! audio #f))
|
||||
(for ((path (in-hash-values cached-media)))
|
||||
(safe-delete-file path))
|
||||
(hash-clear! cached-media))
|
||||
|
||||
(player-agent-runtime start!
|
||||
reconnect!
|
||||
shutdown!
|
||||
snapshot
|
||||
current-track
|
||||
(λ () running)
|
||||
app-id)))
|
||||
@@ -1,413 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket/contract
|
||||
racket/format
|
||||
racket/gui/base
|
||||
racket/os
|
||||
racket/runtime-path
|
||||
racket/string
|
||||
racket-tray
|
||||
simple-log
|
||||
"player-agent-config.rkt"
|
||||
"player-agent-core.rkt"
|
||||
"translate.rkt")
|
||||
|
||||
(provide run-player-agent-gui)
|
||||
|
||||
(sl-def-log player-agent-gui)
|
||||
|
||||
(define log-file
|
||||
(build-path (find-system-path 'pref-dir)
|
||||
"rkt-web-player-agent.log"))
|
||||
|
||||
(define-runtime-path tray-icon
|
||||
"../public/rkt-web-player.png")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create a labelled text field with compact editor padding.
|
||||
; pre : label and init-value are strings; panel accepts GUI children.
|
||||
; post : A text field has been added to panel.
|
||||
; result : The newly created text-field% object.
|
||||
; internals:
|
||||
; Padding is set on the editor because it renders consistently on
|
||||
; the supported desktop platforms.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (input-field label init-value panel)
|
||||
(let ((field
|
||||
(new text-field%
|
||||
(parent panel)
|
||||
(label label)
|
||||
(init-value init-value))))
|
||||
(send (send field get-editor) set-padding 0 2 0 2)
|
||||
field))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Format a playback position as hours, minutes and seconds.
|
||||
; pre : value is any Racket value.
|
||||
; post : No state is changed.
|
||||
; result : A zero-padded HH:MM:SS string; invalid values are treated as zero.
|
||||
; internals:
|
||||
; Fractional seconds are deliberately rounded down so the displayed
|
||||
; position never runs ahead of the audio runtime.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (format-time value)
|
||||
(let* ((seconds
|
||||
(if (and (number? value) (>= value 0))
|
||||
(inexact->exact (floor value))
|
||||
0))
|
||||
(hours (quotient seconds 3600))
|
||||
(minutes (quotient (remainder seconds 3600) 60))
|
||||
(remaining (remainder seconds 60)))
|
||||
(format "~a:~a:~a"
|
||||
(~r hours #:min-width 2 #:pad-string "0")
|
||||
(~r minutes #:min-width 2 #:pad-string "0")
|
||||
(~r remaining #:min-width 2 #:pad-string "0"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Start the graphical polling playback agent.
|
||||
; pre : A graphical desktop and the platform support required by
|
||||
; racket-tray are available.
|
||||
; post : The agent runtime is started, its frame and tray icon are visible,
|
||||
; and closing or minimizing the frame hides it in the system tray.
|
||||
; result : The live frame% object belonging to the playback agent.
|
||||
; internals:
|
||||
; The GUI owns only widgets, configuration and lifecycle callbacks.
|
||||
; Playback and polling remain in player-agent-core.rkt. racket-tray
|
||||
; owns native tray resources and the portable minimize watcher.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (run-player-agent-gui)
|
||||
(-> (is-a?/c frame%))
|
||||
(sl-log-to-file log-file)
|
||||
(let ((config (load-player-agent-config))
|
||||
(frame #f)
|
||||
(runtime #f)
|
||||
(status-message #f)
|
||||
(playback-message #f)
|
||||
(playback-details #f)
|
||||
(playback-filename #f)
|
||||
(name-field #f)
|
||||
(server-field #f)
|
||||
(connect-button #f)
|
||||
(playback-timer #f)
|
||||
(tray #f)
|
||||
(shutting-down? #f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Queue a status-label update in the GUI eventspace.
|
||||
; pre : message is a string supplied by the agent runtime.
|
||||
; post : The status widget shows message when it has been created.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; Runtime callbacks can originate outside the GUI eventspace, so
|
||||
; widget access is always forwarded with queue-callback.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (show-status! message)
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(when status-message
|
||||
(send status-message set-label message)))
|
||||
#f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Show a playback-agent authorization failure.
|
||||
; pre : message is a string supplied by the agent runtime.
|
||||
; post : A modal error dialog is queued for the agent frame.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; The callback is eventspace-safe for the same reason as the
|
||||
; status callback above.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (show-denial! message)
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(message-box (tr 'denied-title)
|
||||
message
|
||||
frame
|
||||
'(ok stop)))
|
||||
#f))
|
||||
|
||||
(set! runtime
|
||||
(make-player-agent-runtime
|
||||
(player-agent-config-server-url config)
|
||||
(player-agent-config-name config)
|
||||
(player-agent-config-app-id config)
|
||||
#:status-callback show-status!
|
||||
#:denied-callback show-denial!))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Refresh the visible playback summary from the runtime cache.
|
||||
; pre : runtime exists; the widgets may still be uninitialized.
|
||||
; post : Initialized playback widgets reflect one coherent cached
|
||||
; snapshot and its current track.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; This procedure never performs network I/O. The timer reads only
|
||||
; the cache maintained by player-agent-core.rkt.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (refresh-playback-status!)
|
||||
(when (and playback-message playback-details playback-filename)
|
||||
(let* ((snapshot ((player-agent-runtime-snapshot runtime)))
|
||||
(track ((player-agent-runtime-current-track runtime)))
|
||||
(state (hash-ref snapshot 'state "stopped"))
|
||||
(title (and track (hash-ref track 'title #f)))
|
||||
(artist (and track (hash-ref track 'artist #f)))
|
||||
(filename (and track (hash-ref track 'filename #f)))
|
||||
(track-number (and track (hash-ref track 'trackNumber #f)))
|
||||
(track-label
|
||||
(cond
|
||||
((and artist (not (string=? artist "")) title)
|
||||
(format "~a — ~a" artist title))
|
||||
(title title)
|
||||
(else (tr 'no-track-selected))))
|
||||
(prefix
|
||||
(cond
|
||||
((string=? state "playing") (tr 'playing))
|
||||
((string=? state "paused") (tr 'paused))
|
||||
((string=? state "starting") (tr 'loading))
|
||||
((string=? state "stopped") (tr 'stopped))
|
||||
(else state)))
|
||||
(position (hash-ref snapshot 'position 0))
|
||||
(duration (hash-ref snapshot 'duration 'null))
|
||||
(format-name (hash-ref snapshot 'format ""))
|
||||
(rate (hash-ref snapshot 'rate 'null))
|
||||
(bits (hash-ref snapshot 'bits 'null))
|
||||
(channels (hash-ref snapshot 'channels 'null))
|
||||
(details
|
||||
(filter
|
||||
(λ (value) (not (string=? value "")))
|
||||
(list
|
||||
(format "~a / ~a"
|
||||
(format-time position)
|
||||
(if (number? duration)
|
||||
(format-time duration)
|
||||
"--:--:--"))
|
||||
(if (number? bits) (format "~a bit" bits) "")
|
||||
(if (number? rate)
|
||||
(format "~a kHz"
|
||||
(~r (/ rate 1000.0) #:precision '(= 1)))
|
||||
"")
|
||||
(if (number? channels)
|
||||
(format "~a ~a"
|
||||
channels
|
||||
(tr (if (= channels 1) 'channel 'channels)))
|
||||
"")
|
||||
(if (and (string? format-name)
|
||||
(not (string=? format-name "")))
|
||||
format-name
|
||||
"")))))
|
||||
(send playback-message
|
||||
set-label
|
||||
(if track
|
||||
(format "~a~a: ~a"
|
||||
prefix
|
||||
(if (number? track-number)
|
||||
(format " #~a" track-number)
|
||||
"")
|
||||
track-label)
|
||||
(tr 'no-track)))
|
||||
(send playback-details set-label (string-join details " · "))
|
||||
(send playback-filename
|
||||
set-label
|
||||
(if (and (string? filename)
|
||||
(not (string=? filename "")))
|
||||
filename
|
||||
"—")))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Persist edited connection settings and reconnect the runtime.
|
||||
; pre : The name, server and connect widgets have been initialized.
|
||||
; post : config and the INI file contain normalized values; the runtime
|
||||
; reconnects with them and the button becomes a reconnect button.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; An empty name receives the same hostname-based default used by
|
||||
; initial configuration loading.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (reconnect!)
|
||||
(let* ((next-server (string-trim (send server-field get-value)))
|
||||
(entered-name (string-trim (send name-field get-value)))
|
||||
(next-name
|
||||
(if (string=? entered-name "")
|
||||
(format "~a playback" (gethostname))
|
||||
entered-name)))
|
||||
(set! config
|
||||
(struct-copy player-agent-config config
|
||||
(server-url next-server)
|
||||
(name next-name)))
|
||||
(save-player-agent-config! config)
|
||||
(send name-field set-value next-name)
|
||||
((player-agent-runtime-reconnect! runtime) next-server next-name)
|
||||
(send connect-button set-label (tr 'reconnect))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Release resources owned by the GUI agent exactly once.
|
||||
; pre : runtime has been created; timer and tray may be #f.
|
||||
; post : Playback polling, audio, the GUI timer and native tray resources
|
||||
; have stopped; subsequent calls do nothing.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; The guard makes this procedure safe from both the window close
|
||||
; path and the tray Exit action.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (shutdown!)
|
||||
(unless shutting-down?
|
||||
(set! shutting-down? #t)
|
||||
(when playback-timer
|
||||
(send playback-timer stop))
|
||||
((player-agent-runtime-shutdown! runtime))
|
||||
(when tray
|
||||
(tray-close tray)
|
||||
(set! tray #f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Terminate the graphical agent from its tray menu.
|
||||
; pre : frame and runtime have been initialized.
|
||||
; post : Resources are released and the frame is hidden.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; racket-tray invokes actions in the frame eventspace, so no
|
||||
; additional GUI callback queue is needed here.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (quit!)
|
||||
(shutdown!)
|
||||
(send frame show #f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Restore the agent frame from the tray.
|
||||
; pre : frame has been initialized and has not been destroyed.
|
||||
; post : frame is visible and no longer iconized.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; De-iconizing is needed because racket-tray hides minimized
|
||||
; frames instead of changing their iconized state.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (show-window!)
|
||||
(send frame show #t)
|
||||
(when (send frame is-iconized?)
|
||||
(send frame iconize #f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Dispatch a symbolic racket-tray action.
|
||||
; pre : action is installed in the tray menu below.
|
||||
; post : 'open restores the frame; 'exit shuts down the agent.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; One callback handles both direct tray activation and menu
|
||||
; selection on every platform.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (tray-action! action)
|
||||
(case action
|
||||
((open) (show-window!))
|
||||
((exit) (quit!))))
|
||||
|
||||
(let* ((agent-frame%
|
||||
(class frame%
|
||||
(super-new)
|
||||
(define/augment (on-close)
|
||||
(if tray
|
||||
(send this show #f)
|
||||
(begin
|
||||
(shutdown!)
|
||||
(inner (void) on-close))))))
|
||||
(new-frame
|
||||
(new agent-frame%
|
||||
(label (tr 'app-title))
|
||||
(width 560)
|
||||
(height 310))))
|
||||
(set! frame new-frame))
|
||||
|
||||
(let* ((panel
|
||||
(new vertical-panel%
|
||||
(parent frame)
|
||||
(alignment '(left top))))
|
||||
(server
|
||||
(input-field (tr 'server)
|
||||
(player-agent-config-server-url config)
|
||||
panel))
|
||||
(name
|
||||
(input-field (tr 'name)
|
||||
(player-agent-config-name config)
|
||||
panel))
|
||||
(id-field
|
||||
(input-field (tr 'application-id)
|
||||
(player-agent-config-app-id config)
|
||||
panel))
|
||||
(playback-panel
|
||||
(new group-box-panel%
|
||||
(parent panel)
|
||||
(label (tr 'playback))
|
||||
(alignment '(left top))
|
||||
(stretchable-height #f)))
|
||||
(controls
|
||||
(new horizontal-panel%
|
||||
(parent panel)
|
||||
(alignment '(left center)))))
|
||||
(set! server-field server)
|
||||
(set! name-field name)
|
||||
;; Lock the editor, not the native widget. Disabled Windows controls
|
||||
;; render their label and text poorly on some display configurations.
|
||||
(send (send id-field get-editor) lock #t)
|
||||
(set! playback-message
|
||||
(new message%
|
||||
(parent playback-panel)
|
||||
(label (tr 'no-track))
|
||||
(auto-resize #t)))
|
||||
(set! playback-details
|
||||
(new message%
|
||||
(parent playback-panel)
|
||||
(label "00:00:00 / --:--:--")
|
||||
(auto-resize #t)))
|
||||
(set! playback-filename
|
||||
(new message%
|
||||
(parent playback-panel)
|
||||
(label "—")
|
||||
(auto-resize #t)))
|
||||
(set! connect-button
|
||||
(new button%
|
||||
(parent controls)
|
||||
(label (tr 'save-connect))
|
||||
(callback (λ (_button _event) (reconnect!)))))
|
||||
(set! status-message
|
||||
(new message%
|
||||
(parent controls)
|
||||
(label (tr 'connecting))
|
||||
(auto-resize #t))))
|
||||
|
||||
(set! playback-timer
|
||||
(new timer%
|
||||
(notify-callback refresh-playback-status!)
|
||||
(interval 500)))
|
||||
(refresh-playback-status!)
|
||||
|
||||
(set! tray
|
||||
(mk-tray frame
|
||||
tray-icon
|
||||
(list tray-action! 'open)
|
||||
#:hide-on-minimize? #t))
|
||||
(tray-set-menu!
|
||||
tray
|
||||
(list
|
||||
(list 'open (tr 'tray-open))
|
||||
'separator
|
||||
(list 'exit (tr 'quit))))
|
||||
|
||||
(send frame show #t)
|
||||
((player-agent-runtime-start! runtime))
|
||||
(send connect-button set-label (tr 'reconnect))
|
||||
frame))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
;; The runtime path must remain valid after package installation; relying on
|
||||
;; the development working directory would make the tray fail elsewhere.
|
||||
(check-true (file-exists? tray-icon)))
|
||||
+29
-5
@@ -15,7 +15,8 @@
|
||||
"library.rkt"
|
||||
"playlists.rkt")
|
||||
|
||||
(provide make-player
|
||||
(provide player?
|
||||
make-player
|
||||
player-state->jsexpr
|
||||
player-command!
|
||||
player-discover!
|
||||
@@ -73,9 +74,19 @@
|
||||
[volume #:mutable]
|
||||
[repeat #:mutable]
|
||||
[error #:mutable]
|
||||
local-music-indexes)
|
||||
local-music-indexes)
|
||||
#:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Hold the shared libraries, playback sessions, outputs and UI state.
|
||||
; pre : make-player supplies all fields and owns construction of the value.
|
||||
; post : Creating or recognizing a player does not start an HTTP server.
|
||||
; result : player? recognizes values accepted by the internal server API.
|
||||
; internals: make-player initializes the state and command locks, playlist
|
||||
; contexts and playback sessions. player-command! mutates that
|
||||
; state, player-state->jsexpr reads it, and player-close! releases
|
||||
; the owned playback and persistence resources.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(struct player
|
||||
(libraries
|
||||
allowed-agent-ids
|
||||
@@ -373,6 +384,13 @@
|
||||
(λ ()
|
||||
(set-playback-session-error! session message))))
|
||||
|
||||
;;; Converts an internal error value to a JSON-compatible message or key.
|
||||
(define (error->jsexpr error)
|
||||
(cond
|
||||
((eq? error #f) 'null)
|
||||
((symbol? error) (symbol->string error))
|
||||
(else error)))
|
||||
|
||||
(define (clear-session-error! value session)
|
||||
(set-session-error! value session #f))
|
||||
|
||||
@@ -1372,9 +1390,9 @@
|
||||
'volume (playback-session-volume session)
|
||||
'repeat (symbol->string (playback-session-repeat session))
|
||||
'discovering (player-discovering? value)
|
||||
'error (or (playback-session-error session)
|
||||
(player-error value)
|
||||
'null))))))))
|
||||
'error (error->jsexpr
|
||||
(or (playback-session-error session)
|
||||
(player-error value))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Execute one browser player command.
|
||||
@@ -1722,6 +1740,12 @@
|
||||
(require rackunit
|
||||
racket/file)
|
||||
|
||||
(check-equal? (error->jsexpr #f) 'null)
|
||||
(check-equal?
|
||||
(error->jsexpr 'dlna-renderer-unreachable)
|
||||
"dlna-renderer-unreachable")
|
||||
(check-equal? (error->jsexpr "technical error") "technical error")
|
||||
|
||||
(define root
|
||||
(make-temporary-file "rkt-web-player-~a" 'directory))
|
||||
|
||||
|
||||
+253
-156
@@ -1,6 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
(require keystore
|
||||
racket/contract
|
||||
racket/file
|
||||
racket/list
|
||||
racket/path
|
||||
@@ -15,18 +16,32 @@
|
||||
load-user-language
|
||||
save-user-language!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Represent one named playlist tab in durable player state.
|
||||
; pre : Id is a UUID string, name is non-empty, and tracks contains tracks.
|
||||
; post : Constructing or inspecting a value changes no external state.
|
||||
; result : persisted-tab? recognizes stored and restored playlist tabs.
|
||||
; internals: track->datum serializes the tracks and datum->tab reconstructs
|
||||
; this value after validating its id, name and track collection.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(struct persisted-tab (id name tracks) #:transparent)
|
||||
(struct playlist-store (keystore lock) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Produces the keystore key containing one user's ordered playlist ids.
|
||||
(define (user-playlists-key username)
|
||||
(format "playlists-for-~a" username))
|
||||
|
||||
;;; Produces the keystore key containing one user's language preference.
|
||||
(define (user-language-key username)
|
||||
(format "language-for-~a" username))
|
||||
|
||||
(define supported-language-names
|
||||
'("en" "nl" "de" "fr" "es" "it" "sv" "no" "fi" "is"))
|
||||
|
||||
;;; Serializes a track without exposing the track struct to the keystore.
|
||||
(define (track->datum item)
|
||||
(hasheq 'file (path->string (track-file item))
|
||||
'title (track-title item)
|
||||
@@ -35,111 +50,177 @@
|
||||
'duration (or (track-duration item) #f)
|
||||
'mime-type (or (track-mime-type item) #f)))
|
||||
|
||||
;;; Checks whether a stored optional value is #f or a string.
|
||||
(define (optional-string? value)
|
||||
(or (not value) (string? value)))
|
||||
(or (eq? value #f) (string? value)))
|
||||
|
||||
;;; Validates and restores one stored track.
|
||||
;;; Files outside the configured libraries are deliberately rejected.
|
||||
(define (datum->track value libraries)
|
||||
(and (hash? value)
|
||||
(let ((file (hash-ref value 'file #f))
|
||||
(if (not (hash? value))
|
||||
#f
|
||||
(let* ((file (hash-ref value 'file #f))
|
||||
(title (hash-ref value 'title #f))
|
||||
(artist (hash-ref value 'artist #f))
|
||||
(album (hash-ref value 'album #f))
|
||||
(duration (hash-ref value 'duration #f))
|
||||
(mime-type (hash-ref value 'mime-type #f)))
|
||||
(and (path-string? file)
|
||||
(string? title)
|
||||
(string? artist)
|
||||
(string? album)
|
||||
(or (not duration)
|
||||
(and (number? duration) (not (negative? duration))))
|
||||
(optional-string? mime-type)
|
||||
(library-contains-audio-file? libraries file)
|
||||
(track (path->complete-path file)
|
||||
title artist album duration mime-type)))))
|
||||
(mime-type (hash-ref value 'mime-type #f))
|
||||
(valid-duration?
|
||||
(or (eq? duration #f)
|
||||
(and (number? duration)
|
||||
(not (negative? duration)))))
|
||||
(valid-metadata?
|
||||
(and (path-string? file)
|
||||
(string? title)
|
||||
(string? artist)
|
||||
(string? album)
|
||||
valid-duration?
|
||||
(optional-string? mime-type))))
|
||||
(if (and valid-metadata?
|
||||
(library-contains-audio-file? libraries file))
|
||||
(track (path->complete-path file)
|
||||
title artist album duration mime-type)
|
||||
#f))))
|
||||
|
||||
;;; Validates and restores one tab while discarding invalid track entries.
|
||||
(define (datum->tab id value libraries)
|
||||
(and (uuid-string? id)
|
||||
(hash? value)
|
||||
(let ((name (hash-ref value 'name #f))
|
||||
(tracks (hash-ref value 'tracks #f)))
|
||||
(and (string? name)
|
||||
(not (string=? name ""))
|
||||
(list? tracks)
|
||||
(persisted-tab
|
||||
id
|
||||
name
|
||||
(filter-map
|
||||
(λ (item) (datum->track item libraries))
|
||||
tracks))))))
|
||||
(if (not (and (uuid-string? id) (hash? value)))
|
||||
#f
|
||||
(let ((name (hash-ref value 'name #f))
|
||||
(tracks (hash-ref value 'tracks #f)))
|
||||
(if (and (string? name)
|
||||
(not (string=? name ""))
|
||||
(list? tracks))
|
||||
(persisted-tab
|
||||
id
|
||||
name
|
||||
(filter-map
|
||||
(λ (item) (datum->track item libraries))
|
||||
tracks))
|
||||
#f))))
|
||||
|
||||
(define (open-playlist-store file)
|
||||
(and file
|
||||
(let ((target (path->complete-path file)))
|
||||
(make-parent-directory* target)
|
||||
(playlist-store (ks-open target) (make-semaphore 1)))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (close-playlist-store! store)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Open the durable store used for playlists and user preferences.
|
||||
; pre : File is #f or a writable keystore path.
|
||||
; post : The parent directory and keystore exist when file is provided.
|
||||
; result : An open keystore handle, or #f when persistence is disabled.
|
||||
; internals: path->complete-path fixes the storage location, ks-open creates or
|
||||
; opens the keystore, and later operations use the lock belonging to
|
||||
; the returned handle.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (open-playlist-store file)
|
||||
(-> (or/c path-string? #f) (or/c keystore? #f))
|
||||
(if (eq? file #f)
|
||||
#f
|
||||
(let ((target (path->complete-path file)))
|
||||
(make-parent-directory* target)
|
||||
(ks-open target))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Close an open playlist store.
|
||||
; pre : Store is #f or was returned by open-playlist-store.
|
||||
; post : Its keystore handle is closed; #f remains a harmless no-op.
|
||||
; result : Void.
|
||||
; internals: ks-with-lock uses the lock belonging to the keystore handle and
|
||||
; prevents ks-close from overlapping a load or save operation.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (close-playlist-store! store)
|
||||
(-> (or/c keystore? #f) void?)
|
||||
(when store
|
||||
(call-with-semaphore
|
||||
(playlist-store-lock store)
|
||||
(λ () (ks-close (playlist-store-keystore store)))))
|
||||
(ks-with-lock store (λ () (ks-close store))))
|
||||
(void))
|
||||
|
||||
(define (load-user-playlists store username libraries)
|
||||
(if (not store)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Restore one user's ordered playlist tabs.
|
||||
; pre : Store is #f or open, username is normalized, and libraries are valid.
|
||||
; post : Store contents remain unchanged and unsafe track paths are omitted.
|
||||
; result : Valid persisted-tab values in their saved order.
|
||||
; internals: ks-with-lock serializes the index and tab reads on the keystore
|
||||
; handle. user-playlists-key locates the UUID index; datum->tab then
|
||||
; validates each referenced tab and delegates track safety checks to
|
||||
; datum->track.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (load-user-playlists store username libraries)
|
||||
(-> (or/c keystore? #f)
|
||||
string?
|
||||
(listof music-library?)
|
||||
(listof persisted-tab?))
|
||||
(if (eq? store #f)
|
||||
'()
|
||||
(call-with-semaphore
|
||||
(playlist-store-lock store)
|
||||
(ks-with-lock
|
||||
store
|
||||
(λ ()
|
||||
(define ks (playlist-store-keystore store))
|
||||
(define ids (ks-get ks (user-playlists-key username) '()))
|
||||
(if (list? ids)
|
||||
(filter-map
|
||||
(λ (id)
|
||||
(datum->tab id (ks-get ks id #f) libraries))
|
||||
(remove-duplicates (filter uuid-string? ids) string=?))
|
||||
'())))))
|
||||
(let ((ids (ks-get store (user-playlists-key username) '())))
|
||||
(if (list? ids)
|
||||
(filter-map
|
||||
(λ (id)
|
||||
(datum->tab id (ks-get store id #f) libraries))
|
||||
(remove-duplicates (filter uuid-string? ids) string=?))
|
||||
'()))))))
|
||||
|
||||
(define (save-user-playlists! store username tabs)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Persist one user's complete ordered collection of playlist tabs.
|
||||
; pre : Store is #f or open, username is normalized, and tabs are valid.
|
||||
; post : The UUID index and tab data match tabs; omitted old tabs are removed.
|
||||
; result : Void.
|
||||
; internals: ks-with-lock prevents another operation from entering this update.
|
||||
; ks-transaction removes stale ids from user-playlists-key, stores
|
||||
; every tab using track->datum, and atomically replaces the index.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (save-user-playlists! store username tabs)
|
||||
(-> (or/c keystore? #f) string? (listof persisted-tab?) void?)
|
||||
(when store
|
||||
(call-with-semaphore
|
||||
(playlist-store-lock store)
|
||||
(ks-with-lock
|
||||
store
|
||||
(λ ()
|
||||
(define ks (playlist-store-keystore store))
|
||||
(define index-key (user-playlists-key username))
|
||||
(define old-ids (ks-get ks index-key '()))
|
||||
(define ids (map persisted-tab-id tabs))
|
||||
(ks-transaction
|
||||
ks
|
||||
(for ((id (in-list (if (list? old-ids) old-ids '())))
|
||||
#:when (and (string? id) (not (member id ids string=?))))
|
||||
(ks-drop! ks id))
|
||||
(for ((tab (in-list tabs)))
|
||||
(ks-set!
|
||||
ks
|
||||
(persisted-tab-id tab)
|
||||
(hasheq 'name (persisted-tab-name tab)
|
||||
'tracks (map track->datum
|
||||
(persisted-tab-tracks tab)))))
|
||||
(ks-set! ks index-key ids))
|
||||
(void)))))
|
||||
(let* ((index-key (user-playlists-key username))
|
||||
(old-ids (ks-get store index-key '()))
|
||||
(ids (map persisted-tab-id tabs))
|
||||
(stale-ids
|
||||
(filter
|
||||
(λ (id)
|
||||
(and (string? id)
|
||||
(not (member id ids string=?))))
|
||||
(if (list? old-ids) old-ids '()))))
|
||||
(ks-transaction
|
||||
store
|
||||
(for-each (λ (id) (ks-drop! store id)) stale-ids)
|
||||
(for-each
|
||||
(λ (tab)
|
||||
(ks-set!
|
||||
store
|
||||
(persisted-tab-id tab)
|
||||
(hasheq 'name (persisted-tab-name tab)
|
||||
'tracks (map track->datum
|
||||
(persisted-tab-tracks tab)))))
|
||||
tabs)
|
||||
(ks-set! store index-key ids))
|
||||
(void)))))
|
||||
(void))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Load one user's persisted interface language.
|
||||
; pre : Store is #f or an open playlist store; username is normalized.
|
||||
; post : Store contents remain unchanged.
|
||||
; result : A supported ISO language name, or #f when none was saved.
|
||||
; internals: user-language-key selects the keystore entry while ks-with-lock
|
||||
; holds the handle's lock. Only supported language names return.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (load-user-language store username)
|
||||
(and store
|
||||
(call-with-semaphore
|
||||
(playlist-store-lock store)
|
||||
(λ ()
|
||||
(define value
|
||||
(ks-get (playlist-store-keystore store)
|
||||
(user-language-key username)
|
||||
#f))
|
||||
(and (member value supported-language-names) value)))))
|
||||
(define/contract (load-user-language store username)
|
||||
(-> (or/c keystore? #f) string? (or/c string? #f))
|
||||
(if (eq? store #f)
|
||||
#f
|
||||
(ks-with-lock
|
||||
store
|
||||
(λ ()
|
||||
(let ((value (ks-get store (user-language-key username) #f)))
|
||||
(if (member value supported-language-names)
|
||||
value
|
||||
#f))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Persist one user's interface language.
|
||||
@@ -147,22 +228,27 @@
|
||||
; en, nl, de, fr, es, it, sv, no, fi, or is.
|
||||
; post : The user's language key contains language when a store exists.
|
||||
; result : Void.
|
||||
; internals: Validation precedes persistence. user-language-key identifies the
|
||||
; entry and ks-with-lock serializes the ks-set! call on the handle.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-user-language! store username language)
|
||||
(define/contract (save-user-language! store username language)
|
||||
(-> (or/c keystore? #f) string? string? void?)
|
||||
(unless (member language supported-language-names)
|
||||
(raise-argument-error
|
||||
'save-user-language!
|
||||
"one of en, nl, de, fr, es, it, sv, no, fi, or is"
|
||||
language))
|
||||
(when store
|
||||
(call-with-semaphore
|
||||
(playlist-store-lock store)
|
||||
(ks-with-lock
|
||||
store
|
||||
(λ ()
|
||||
(ks-set! (playlist-store-keystore store)
|
||||
(user-language-key username)
|
||||
language))))
|
||||
(ks-set! store (user-language-key username) language))))
|
||||
(void))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tests for module playlists.rkt
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
uuid/random)
|
||||
@@ -173,6 +259,11 @@
|
||||
(define music-two (build-path root "music-two"))
|
||||
(define outside (build-path root "outside.flac"))
|
||||
(define store-file (build-path root "data" "playlists.keystore"))
|
||||
|
||||
(check-false (open-playlist-store #f))
|
||||
(check-equal? (load-user-playlists #f "hans" '()) '())
|
||||
(check-false (load-user-language #f "hans"))
|
||||
|
||||
(dynamic-wind
|
||||
(λ ()
|
||||
(make-directory music)
|
||||
@@ -181,76 +272,82 @@
|
||||
(call-with-output-file (build-path music-two "two.flac") void)
|
||||
(call-with-output-file outside void))
|
||||
(λ ()
|
||||
(define libraries (make-music-libraries (list music music-two)))
|
||||
(define store (open-playlist-store store-file))
|
||||
(define first-id (uuid-string))
|
||||
(define second-id (uuid-string))
|
||||
(define item
|
||||
(track (build-path music "one.flac")
|
||||
"One" "Artist" "Album" 60 "audio/flac"))
|
||||
(define item-two
|
||||
(track (build-path music-two "two.flac")
|
||||
"Two" "Artist" "Album" 70 "audio/flac"))
|
||||
(save-user-playlists!
|
||||
store
|
||||
"hans"
|
||||
(list (persisted-tab first-id "First" (list item item-two))
|
||||
(persisted-tab second-id "Second" '())))
|
||||
(save-user-playlists!
|
||||
store
|
||||
"local"
|
||||
(list (persisted-tab (uuid-string) "Local" '())))
|
||||
(let* ((libraries (make-music-libraries (list music music-two)))
|
||||
(store (open-playlist-store store-file))
|
||||
(first-id (uuid-string))
|
||||
(second-id (uuid-string))
|
||||
(item
|
||||
(track (build-path music "one.flac")
|
||||
"One" "Artist" "Album" 60 "audio/flac"))
|
||||
(item-two
|
||||
(track (build-path music-two "two.flac")
|
||||
"Two" "Artist" "Album" 70 "audio/flac")))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(save-user-playlists!
|
||||
store
|
||||
"hans"
|
||||
(list (persisted-tab first-id "First" (list item item-two))
|
||||
(persisted-tab second-id "Second" '())))
|
||||
(save-user-playlists!
|
||||
store
|
||||
"local"
|
||||
(list (persisted-tab (uuid-string) "Local" '())))
|
||||
(let ((loaded (load-user-playlists store "hans" libraries)))
|
||||
(check-equal? (ks-get store "playlists-for-hans")
|
||||
(list first-id second-id))
|
||||
(check-equal? (hash-ref (ks-get store first-id) 'name) "First")
|
||||
(check-equal? (map persisted-tab-id loaded)
|
||||
(list first-id second-id))
|
||||
(check-equal? (persisted-tab-name (car loaded)) "First")
|
||||
(check-equal?
|
||||
(map track-title (persisted-tab-tracks (car loaded)))
|
||||
'("One" "Two"))
|
||||
(check-equal?
|
||||
(map persisted-tab-name
|
||||
(load-user-playlists store "local" libraries))
|
||||
'("Local"))
|
||||
(check-false (load-user-language store "hans"))
|
||||
(save-user-language! store "hans" "fr")
|
||||
(check-equal? (load-user-language store "hans") "fr")
|
||||
(save-user-language! store "hans" "fi")
|
||||
(check-equal? (load-user-language store "hans") "fi")
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (save-user-language! store "hans" "da")))
|
||||
|
||||
(define loaded (load-user-playlists store "hans" libraries))
|
||||
(define ks (playlist-store-keystore store))
|
||||
(check-equal? (ks-get ks "playlists-for-hans")
|
||||
(list first-id second-id))
|
||||
(check-equal? (hash-ref (ks-get ks first-id) 'name) "First")
|
||||
(check-equal? (map persisted-tab-id loaded) (list first-id second-id))
|
||||
(check-equal? (persisted-tab-name (car loaded)) "First")
|
||||
(check-equal? (map track-title (persisted-tab-tracks (car loaded)))
|
||||
'("One" "Two"))
|
||||
(check-equal?
|
||||
(map persisted-tab-name (load-user-playlists store "local" libraries))
|
||||
'("Local"))
|
||||
(check-false (load-user-language store "hans"))
|
||||
(save-user-language! store "hans" "fr")
|
||||
(check-equal? (load-user-language store "hans") "fr")
|
||||
(save-user-language! store "hans" "fi")
|
||||
(check-equal? (load-user-language store "hans") "fi")
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (save-user-language! store "hans" "da")))
|
||||
;; Rewriting the user's GUID index durably removes the omitted
|
||||
;; playlist instead of leaving it orphaned.
|
||||
(save-user-playlists!
|
||||
store "hans"
|
||||
(list (persisted-tab first-id "First" (list item item-two))))
|
||||
(check-equal?
|
||||
(map persisted-tab-id
|
||||
(load-user-playlists store "hans" libraries))
|
||||
(list first-id))
|
||||
(check-false (ks-exists? store second-id))
|
||||
(check-equal?
|
||||
(map persisted-tab-name
|
||||
(load-user-playlists store "local" libraries))
|
||||
'("Local"))
|
||||
|
||||
;; Rewriting the user's GUID index durably removes the omitted playlist.
|
||||
(save-user-playlists!
|
||||
store "hans"
|
||||
(list (persisted-tab first-id "First" (list item item-two))))
|
||||
(check-equal?
|
||||
(map persisted-tab-id (load-user-playlists store "hans" libraries))
|
||||
(list first-id))
|
||||
(check-false (ks-exists? ks second-id))
|
||||
;; An omitted GUID is deleted rather than becoming orphaned.
|
||||
(check-equal?
|
||||
(map persisted-tab-name (load-user-playlists store "local" libraries))
|
||||
'("Local"))
|
||||
|
||||
;; A playlist entry may not restore tracks outside configured libraries.
|
||||
(define unsafe-id (uuid-string))
|
||||
(ks-set!
|
||||
(playlist-store-keystore store)
|
||||
unsafe-id
|
||||
(hasheq
|
||||
'name "Unsafe"
|
||||
'tracks
|
||||
(list (hasheq 'file (path->string outside)
|
||||
'title "Outside" 'artist "" 'album ""
|
||||
'duration #f 'mime-type "audio/flac"))))
|
||||
(ks-set! (playlist-store-keystore store)
|
||||
(user-playlists-key "unsafe")
|
||||
(list unsafe-id))
|
||||
(check-equal?
|
||||
(persisted-tab-tracks
|
||||
(car (load-user-playlists store "unsafe" libraries)))
|
||||
'())
|
||||
(close-playlist-store! store))
|
||||
;; A playlist may not restore tracks outside configured libraries.
|
||||
(let ((unsafe-id (uuid-string)))
|
||||
(ks-set!
|
||||
store
|
||||
unsafe-id
|
||||
(hasheq
|
||||
'name "Unsafe"
|
||||
'tracks
|
||||
(list (hasheq 'file (path->string outside)
|
||||
'title "Outside" 'artist "" 'album ""
|
||||
'duration #f 'mime-type "audio/flac"))))
|
||||
(ks-set! store
|
||||
(user-playlists-key "unsafe")
|
||||
(list unsafe-id))
|
||||
(check-equal?
|
||||
(persisted-tab-tracks
|
||||
(car (load-user-playlists store "unsafe" libraries)))
|
||||
'()))))
|
||||
(λ () (close-playlist-store! store)))))
|
||||
(λ () (delete-directory/files root))))
|
||||
|
||||
+238
-106
@@ -21,43 +21,46 @@
|
||||
(define-runtime-path public-directory "../public")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; HTTP handlers
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define current-player #f)
|
||||
(define current-auth #f)
|
||||
|
||||
;;; Creates a JSON response that browsers and agents may not cache.
|
||||
(define (json-response value #:code [code 200] #:headers [headers '()])
|
||||
(response/jsexpr
|
||||
value
|
||||
#:code code
|
||||
#:headers (cons (header #"Cache-Control" #"no-store") headers)))
|
||||
|
||||
;;; Converts an ordinary request exception to a bad-request response.
|
||||
(define (error-response exception)
|
||||
(json-response
|
||||
(hasheq 'error (exn-message exception))
|
||||
#:code 400))
|
||||
|
||||
;;; Converts a denied playback agent exception to a forbidden response.
|
||||
(define (agent-error-response exception)
|
||||
(json-response
|
||||
(hasheq 'error (exn-message exception)
|
||||
'code "agent-not-authorized")
|
||||
#:code 403))
|
||||
|
||||
;;; Reads a JSON request body or returns an empty object for an empty body.
|
||||
(define (request-jsexpr request)
|
||||
(let ((body (request-post-data/raw request)))
|
||||
(if (and body (positive? (bytes-length body)))
|
||||
(bytes->jsexpr body)
|
||||
(hasheq))))
|
||||
|
||||
(define (auth-status-handler request)
|
||||
(let ((user (auth-request-user current-auth request)))
|
||||
;;; Reports the authentication state belonging to the current request.
|
||||
(define (auth-status-handler auth request)
|
||||
(let ((user (auth-request-user auth request)))
|
||||
(json-response
|
||||
(hasheq 'enabled (auth-enabled? current-auth)
|
||||
(hasheq 'enabled (auth-enabled? auth)
|
||||
'authenticated (and user #t)
|
||||
'username (or user 'null)))))
|
||||
|
||||
(define (auth-login-handler request)
|
||||
;;; Authenticates a browser and returns its new session cookie.
|
||||
(define (auth-login-handler auth request)
|
||||
(with-handlers ((exn:fail? error-response))
|
||||
(let* ((data (request-jsexpr request))
|
||||
(username (hash-ref data 'username #f))
|
||||
@@ -66,16 +69,16 @@
|
||||
(raise-arguments-error
|
||||
'login
|
||||
"username and password must be strings"))
|
||||
(let ((result (auth-login! current-auth request username password)))
|
||||
(let ((result (auth-login! auth request username password)))
|
||||
(cond
|
||||
((eq? result 'rate-limited)
|
||||
(json-response
|
||||
(hasheq 'error "Te veel mislukte aanmeldpogingen; probeer het over enkele minuten opnieuw"
|
||||
(hasheq 'error "login-rate-limited"
|
||||
'code "login-rate-limited")
|
||||
#:code 429))
|
||||
((not result)
|
||||
(json-response
|
||||
(hasheq 'error "Ongeldige gebruikersnaam of wachtwoord"
|
||||
(hasheq 'error "invalid-credentials"
|
||||
'code "invalid-credentials")
|
||||
#:code 401))
|
||||
(else
|
||||
@@ -84,79 +87,89 @@
|
||||
'username (string-downcase (string-trim username)))
|
||||
#:headers
|
||||
(list (header #"Set-Cookie"
|
||||
(auth-session-cookie current-auth result))))))))))
|
||||
(auth-session-cookie auth result))))))))))
|
||||
|
||||
(define (auth-logout-handler request)
|
||||
(auth-logout! current-auth request)
|
||||
;;; Invalidates the browser session and expires its cookie.
|
||||
(define (auth-logout-handler auth request)
|
||||
(auth-logout! auth request)
|
||||
(json-response
|
||||
(hasheq 'authenticated #f)
|
||||
#:headers
|
||||
(list (header #"Set-Cookie" (auth-expired-cookie)))))
|
||||
|
||||
(define (request-username request)
|
||||
(or (auth-request-user current-auth request) "anonymous"))
|
||||
;;; Resolves the authenticated username or the anonymous playlist owner.
|
||||
(define (request-username auth request)
|
||||
(or (auth-request-user auth request) "anonymous"))
|
||||
|
||||
(define (state-handler request)
|
||||
;;; Returns the player state belonging to the requesting user.
|
||||
(define (state-handler player auth request)
|
||||
(json-response
|
||||
(player-state->jsexpr
|
||||
current-player
|
||||
#:username (request-username request))))
|
||||
player
|
||||
#:username (request-username auth request))))
|
||||
|
||||
(define (discover-handler request)
|
||||
(player-discover! current-player)
|
||||
;;; Starts renderer discovery and returns the updated player state.
|
||||
(define (discover-handler player auth request)
|
||||
(player-discover! player)
|
||||
(json-response
|
||||
(player-state->jsexpr
|
||||
current-player
|
||||
#:username (request-username request))))
|
||||
player
|
||||
#:username (request-username auth request))))
|
||||
|
||||
(define (command-handler request command)
|
||||
;;; Applies one player command for the requesting user.
|
||||
(define (command-handler player auth request command)
|
||||
(with-handlers
|
||||
((exn:fail? error-response))
|
||||
(json-response
|
||||
(player-command!
|
||||
current-player
|
||||
player
|
||||
command
|
||||
(request-jsexpr request)
|
||||
#:username (request-username request)))))
|
||||
#:username (request-username auth request)))))
|
||||
|
||||
(define (preferences-handler request)
|
||||
;;; Returns the persisted interface preferences for the requesting user.
|
||||
(define (preferences-handler player auth request)
|
||||
(json-response
|
||||
(hasheq
|
||||
'language
|
||||
(or (player-user-language
|
||||
current-player
|
||||
#:username (request-username request))
|
||||
player
|
||||
#:username (request-username auth request))
|
||||
'null))))
|
||||
|
||||
(define (preferences-update-handler request)
|
||||
;;; Validates and persists the requesting user's interface language.
|
||||
(define (preferences-update-handler player auth request)
|
||||
(with-handlers ((exn:fail? error-response))
|
||||
(define language (hash-ref (request-jsexpr request) 'language #f))
|
||||
(player-user-language!
|
||||
current-player
|
||||
language
|
||||
#:username (request-username request))
|
||||
(json-response (hasheq 'language language))))
|
||||
(let ((language (hash-ref (request-jsexpr request) 'language #f)))
|
||||
(player-user-language!
|
||||
player
|
||||
language
|
||||
#:username (request-username auth request))
|
||||
(json-response (hasheq 'language language)))))
|
||||
|
||||
(define (agent-register-handler request)
|
||||
;;; Registers or refreshes one allowed polling playback agent.
|
||||
(define (agent-register-handler player request)
|
||||
(with-handlers
|
||||
((exn:fail:agent-denied? agent-error-response)
|
||||
(exn:fail? error-response))
|
||||
(json-response
|
||||
(player-agent-register!
|
||||
current-player
|
||||
player
|
||||
(request-jsexpr request)))))
|
||||
|
||||
(define (agent-poll-handler request)
|
||||
;;; Processes one state report and command poll from a playback agent.
|
||||
(define (agent-poll-handler player request)
|
||||
(with-handlers
|
||||
((exn:fail:agent-denied? agent-error-response)
|
||||
(exn:fail? error-response))
|
||||
(json-response
|
||||
(player-agent-poll!
|
||||
current-player
|
||||
player
|
||||
(request-jsexpr request)))))
|
||||
|
||||
(define (agent-media-handler _request app-id token)
|
||||
(let ((file (player-agent-media current-player app-id token)))
|
||||
;;; Streams the media file identified by an agent's opaque token.
|
||||
(define (agent-media-handler player _request app-id token)
|
||||
(let ((file (player-agent-media player app-id token)))
|
||||
(if (and file (file-exists? file))
|
||||
(response/output
|
||||
(λ (output)
|
||||
@@ -179,50 +192,34 @@
|
||||
(hasheq 'error "media token is invalid or expired")
|
||||
#:code 404))))
|
||||
|
||||
(define (artwork-handler request artwork-id)
|
||||
;;; Streams cached artwork belonging to a track visible to the user.
|
||||
(define (artwork-handler player auth request artwork-id)
|
||||
(let ((value (player-track-artwork
|
||||
current-player
|
||||
player
|
||||
artwork-id
|
||||
#:username (request-username request))))
|
||||
#:username (request-username auth request))))
|
||||
(if value
|
||||
(response/output
|
||||
(λ (output)
|
||||
(write-bytes (artwork-data value) output))
|
||||
#:mime-type
|
||||
(string->bytes/utf-8 (artwork-mime-type value))
|
||||
#:headers
|
||||
(list
|
||||
(header #"Content-Length"
|
||||
(string->bytes/utf-8
|
||||
(number->string
|
||||
(bytes-length (artwork-data value)))))
|
||||
(header #"Cache-Control" #"private, max-age=3600")))
|
||||
(let ((data (artwork-data value)))
|
||||
(response/output
|
||||
(λ (output)
|
||||
(write-bytes data output))
|
||||
#:mime-type
|
||||
(string->bytes/utf-8 (artwork-mime-type value))
|
||||
#:headers
|
||||
(list
|
||||
(header #"Content-Length"
|
||||
(string->bytes/utf-8
|
||||
(number->string (bytes-length data))))
|
||||
(header #"Cache-Control" #"private, max-age=3600"))))
|
||||
(json-response
|
||||
(hasheq 'error "track artwork is unavailable")
|
||||
#:code 404))))
|
||||
|
||||
(define-values (api-dispatch _url)
|
||||
(dispatch-rules
|
||||
[("api" "auth" "status") #:method "get" auth-status-handler]
|
||||
[("api" "auth" "login") #:method "post" auth-login-handler]
|
||||
[("api" "auth" "logout") #:method "post" auth-logout-handler]
|
||||
[("api" "state") #:method "get" state-handler]
|
||||
[("api" "discover") #:method "post" discover-handler]
|
||||
[("api" "preferences") #:method "get" preferences-handler]
|
||||
[("api" "preferences") #:method "post" preferences-update-handler]
|
||||
[("api" "agent" "register") #:method "post" agent-register-handler]
|
||||
[("api" "agent" "poll") #:method "post" agent-poll-handler]
|
||||
[("api" "agent" "media" (string-arg) (string-arg))
|
||||
#:method "get"
|
||||
agent-media-handler]
|
||||
[("api" "artwork" (string-arg)) #:method "get" artwork-handler]
|
||||
[("api" "command" (string-arg))
|
||||
#:method "post"
|
||||
command-handler]))
|
||||
|
||||
;;; Returns the path and query string used to classify an API request.
|
||||
(define (request-path request)
|
||||
(url->string (request-uri request)))
|
||||
|
||||
;;; Checks whether the request declares a JSON entity body.
|
||||
(define (json-request? request)
|
||||
(let ((content-type
|
||||
(headers-assq* #"Content-Type" (request-headers/raw request))))
|
||||
@@ -230,6 +227,7 @@
|
||||
(regexp-match? #px#"(?i:^application/json(?:;|$))"
|
||||
(header-value content-type)))))
|
||||
|
||||
;;; Recognizes endpoints that use authentication rules separate from browsers.
|
||||
(define (public-api-request? request)
|
||||
(regexp-match? #px"^/api/(?:auth|agent)(?:/|$)"
|
||||
(request-path request)))
|
||||
@@ -251,40 +249,95 @@
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Dispatch an API request and renew an eligible browser cookie.
|
||||
; pre : Current-player and current-auth are initialized and request targets
|
||||
; an API route.
|
||||
; pre : Auth is an auth-manager, api-dispatch handles the configured routes,
|
||||
; and request targets an API route.
|
||||
; post : The selected handler has run. A due browser-session renewal is
|
||||
; recorded and returned as Set-Cookie; agent requests never renew it.
|
||||
; result : The HTTP response produced by the API handler, optionally extended
|
||||
; with the renewed session cookie.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (dispatch-api request)
|
||||
(define value (api-dispatch request))
|
||||
(define renewed-cookie
|
||||
(and (not (regexp-match? #px"^/api/agent(?:/|$)"
|
||||
(request-path request)))
|
||||
(auth-renewal-cookie current-auth request)))
|
||||
(if renewed-cookie
|
||||
(response-add-header value (header #"Set-Cookie" renewed-cookie))
|
||||
value))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (dispatch-api auth api-dispatch request)
|
||||
(let* ((value (api-dispatch request))
|
||||
(agent-request?
|
||||
(regexp-match? #px"^/api/agent(?:/|$)" (request-path request)))
|
||||
(renewed-cookie
|
||||
(if agent-request?
|
||||
#f
|
||||
(auth-renewal-cookie auth request))))
|
||||
(if renewed-cookie
|
||||
(response-add-header value (header #"Set-Cookie" renewed-cookie))
|
||||
value)))
|
||||
|
||||
(define (dispatch request)
|
||||
;;; Enforces JSON and authentication requirements before route dispatch.
|
||||
(define (dispatch-request auth api-dispatch request)
|
||||
(cond
|
||||
((and (bytes=? (request-method request) #"POST")
|
||||
(not (json-request? request)))
|
||||
(json-response
|
||||
(hasheq 'error "Content-Type application/json is vereist"
|
||||
(hasheq 'error "json-required"
|
||||
'code "json-required")
|
||||
#:code 415))
|
||||
((or (public-api-request? request)
|
||||
(auth-request-user current-auth request))
|
||||
(dispatch-api request))
|
||||
(auth-request-user auth request))
|
||||
(dispatch-api auth api-dispatch request))
|
||||
(else
|
||||
(json-response
|
||||
(hasheq 'error "Aanmelden is vereist"
|
||||
(hasheq 'error "authentication-required"
|
||||
'code "authentication-required")
|
||||
#:code 401))))
|
||||
|
||||
;;; Binds the player and authentication manager to every declared API route.
|
||||
(define (make-api-dispatch player auth)
|
||||
(let-values
|
||||
(((api-dispatch _url)
|
||||
(dispatch-rules
|
||||
[("api" "auth" "status")
|
||||
#:method "get"
|
||||
(λ (request) (auth-status-handler auth request))]
|
||||
[("api" "auth" "login")
|
||||
#:method "post"
|
||||
(λ (request) (auth-login-handler auth request))]
|
||||
[("api" "auth" "logout")
|
||||
#:method "post"
|
||||
(λ (request) (auth-logout-handler auth request))]
|
||||
[("api" "state")
|
||||
#:method "get"
|
||||
(λ (request) (state-handler player auth request))]
|
||||
[("api" "discover")
|
||||
#:method "post"
|
||||
(λ (request) (discover-handler player auth request))]
|
||||
[("api" "preferences")
|
||||
#:method "get"
|
||||
(λ (request) (preferences-handler player auth request))]
|
||||
[("api" "preferences")
|
||||
#:method "post"
|
||||
(λ (request) (preferences-update-handler player auth request))]
|
||||
[("api" "agent" "register")
|
||||
#:method "post"
|
||||
(λ (request) (agent-register-handler player request))]
|
||||
[("api" "agent" "poll")
|
||||
#:method "post"
|
||||
(λ (request) (agent-poll-handler player request))]
|
||||
[("api" "agent" "media" (string-arg) (string-arg))
|
||||
#:method "get"
|
||||
(λ (request app-id token)
|
||||
(agent-media-handler player request app-id token))]
|
||||
[("api" "artwork" (string-arg))
|
||||
#:method "get"
|
||||
(λ (request artwork-id)
|
||||
(artwork-handler player auth request artwork-id))]
|
||||
[("api" "command" (string-arg))
|
||||
#:method "post"
|
||||
(λ (request command)
|
||||
(command-handler player auth request command))])))
|
||||
api-dispatch))
|
||||
|
||||
;;; Creates the servlet dispatcher whose closure owns one player/auth pair.
|
||||
(define (make-dispatch player auth)
|
||||
(let ((api-dispatch (make-api-dispatch player auth)))
|
||||
(λ (request)
|
||||
(dispatch-request auth api-dispatch request))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -294,6 +347,9 @@
|
||||
; pre : Value is a player, listen-ip is a string, and port is valid.
|
||||
; post : Static files and API routes are served until the server stops.
|
||||
; result : The result returned by serve/servlet.
|
||||
; internals: make-dispatch binds value and auth-manager into one request
|
||||
; closure. make-api-dispatch connects that context to every route;
|
||||
; serve/servlet then serves the closure and public-directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (serve-player value
|
||||
#:auth-manager
|
||||
@@ -301,21 +357,97 @@
|
||||
#:listen-ip [listen-ip "127.0.0.1"]
|
||||
#:port [port 8080]
|
||||
#:launch-browser? [launch-browser? #t])
|
||||
(->* (any/c)
|
||||
(->* (player?)
|
||||
(#:auth-manager auth-manager?
|
||||
#:listen-ip string?
|
||||
#:port exact-positive-integer?
|
||||
#:launch-browser? boolean?)
|
||||
any)
|
||||
(set! current-player value)
|
||||
(set! current-auth auth-manager)
|
||||
(serve/servlet
|
||||
dispatch
|
||||
#:listen-ip listen-ip
|
||||
#:port port
|
||||
#:connection-close? #t
|
||||
#:launch-browser? launch-browser?
|
||||
#:quit? #f
|
||||
#:banner? #t
|
||||
#:servlet-regexp #rx"^/api(?:/|$)"
|
||||
#:extra-files-paths (list public-directory)))
|
||||
(let ((dispatch (make-dispatch value auth-manager)))
|
||||
(serve/servlet
|
||||
dispatch
|
||||
#:listen-ip listen-ip
|
||||
#:port port
|
||||
#:connection-close? #t
|
||||
#:launch-browser? launch-browser?
|
||||
#:quit? #f
|
||||
#:banner? #t
|
||||
#:servlet-regexp #rx"^/api(?:/|$)"
|
||||
#:extra-files-paths (list public-directory))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tests for module server.rkt
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(require racket/promise
|
||||
rackunit)
|
||||
|
||||
;;; Creates an isolated request value for handler and dispatcher tests.
|
||||
(define (test-request method path
|
||||
#:headers [headers '()]
|
||||
#:body [body #f])
|
||||
(request method
|
||||
(string->url path)
|
||||
headers
|
||||
(delay '())
|
||||
body
|
||||
"127.0.0.1"
|
||||
8080
|
||||
"127.0.0.1"))
|
||||
|
||||
;;; Reads the JSON entity produced by a response.
|
||||
(define (response-jsexpr value)
|
||||
(let ((output (open-output-bytes)))
|
||||
((response-output value) output)
|
||||
(bytes->jsexpr (get-output-bytes output))))
|
||||
|
||||
(check-equal?
|
||||
(request-jsexpr (test-request #"POST" "/api/preferences"))
|
||||
(hasheq))
|
||||
(check-equal?
|
||||
(request-jsexpr
|
||||
(test-request #"POST"
|
||||
"/api/preferences"
|
||||
#:body #"{\"language\":\"nl\"}"))
|
||||
(hasheq 'language "nl"))
|
||||
(check-true
|
||||
(json-request?
|
||||
(test-request
|
||||
#"POST"
|
||||
"/api/preferences"
|
||||
#:headers (list (header #"Content-Type"
|
||||
#"application/json; charset=utf-8")))))
|
||||
(check-false (json-request? (test-request #"POST" "/api/preferences")))
|
||||
(check-true (public-api-request? (test-request #"GET" "/api/auth/status")))
|
||||
(check-true (public-api-request? (test-request #"POST" "/api/agent/poll")))
|
||||
(check-false (public-api-request? (test-request #"GET" "/api/state")))
|
||||
|
||||
(let* ((auth (make-auth-manager (list (cons "hans" "$argon2id$unused"))))
|
||||
(request (test-request #"GET" "/api/state"))
|
||||
(response
|
||||
(dispatch-request auth
|
||||
(λ (_) (error 'test "unexpected dispatch"))
|
||||
request)))
|
||||
(check-equal? (response-code response) 401)
|
||||
(check-equal? (hash-ref (response-jsexpr response) 'error)
|
||||
"authentication-required"))
|
||||
|
||||
(let* ((auth (make-auth-manager '()))
|
||||
(request (test-request #"POST" "/api/state"))
|
||||
(response
|
||||
(dispatch-request auth
|
||||
(λ (_) (error 'test "unexpected dispatch"))
|
||||
request)))
|
||||
(check-equal? (response-code response) 415)
|
||||
(check-equal? (hash-ref (response-jsexpr response) 'error)
|
||||
"json-required"))
|
||||
|
||||
(let* ((auth (make-auth-manager '()))
|
||||
(dispatch (make-dispatch 'unused-player auth))
|
||||
(response (dispatch (test-request #"GET" "/api/auth/status")))
|
||||
(data (response-jsexpr response)))
|
||||
(check-equal? (response-code response) 200)
|
||||
(check-false (hash-ref data 'enabled))
|
||||
(check-true (hash-ref data 'authenticated))
|
||||
(check-equal? (hash-ref data 'username) "anonymous")))
|
||||
|
||||
@@ -1,362 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/string)
|
||||
|
||||
(provide tr
|
||||
__
|
||||
languages
|
||||
set-lang!
|
||||
current-lang)
|
||||
|
||||
(define translation-map
|
||||
(hasheq
|
||||
'en
|
||||
(hasheq
|
||||
'app-title "RKT Web Player Agent"
|
||||
'server "RKT Web Player server"
|
||||
'name "Name"
|
||||
'application-id "Application ID"
|
||||
'playback "Playback"
|
||||
'no-track "Nothing is playing"
|
||||
'no-track-selected "No track selected"
|
||||
'save-connect "Save and connect"
|
||||
'reconnect "Reconnect"
|
||||
'connecting "Connecting…"
|
||||
'connected "Connected"
|
||||
'denied-title "Playback agent not allowed"
|
||||
'denied-message "This playback agent is not allowed by the server. Add the following application ID to [playback-agents] in the server INI:\n\n~a"
|
||||
'unauthorized-status "Not authorized — application ID is not in the server INI"
|
||||
'disconnected "Not connected: ~a"
|
||||
'playing "Playing"
|
||||
'paused "Paused"
|
||||
'loading "Loading"
|
||||
'stopped "Stopped"
|
||||
'channel "channel"
|
||||
'channels "channels"
|
||||
'tray-open "Open RKT Web Player Agent"
|
||||
'quit "Quit")
|
||||
'nl
|
||||
(hasheq
|
||||
'app-title "RKT Web Player Agent"
|
||||
'server "RKT Web Player server"
|
||||
'name "Naam"
|
||||
'application-id "Applicatie-ID"
|
||||
'playback "Afspelen"
|
||||
'no-track "Er wordt niets afgespeeld"
|
||||
'no-track-selected "Geen track geselecteerd"
|
||||
'save-connect "Opslaan en verbinden"
|
||||
'reconnect "Opnieuw verbinden"
|
||||
'connecting "Verbinden…"
|
||||
'connected "Verbonden"
|
||||
'denied-title "Playback agent niet toegestaan"
|
||||
'denied-message "Deze playback agent is niet toegelaten door de server. Voeg het volgende applicatie-ID toe aan [playback-agents] in de server-INI:\n\n~a"
|
||||
'unauthorized-status "Niet geautoriseerd — applicatie-ID staat niet in de server-INI"
|
||||
'disconnected "Niet verbonden: ~a"
|
||||
'playing "Speelt"
|
||||
'paused "Gepauzeerd"
|
||||
'loading "Laden"
|
||||
'stopped "Gestopt"
|
||||
'channel "kanaal"
|
||||
'channels "kanalen"
|
||||
'tray-open "RKT Web Player Agent openen"
|
||||
'quit "Afsluiten")
|
||||
'de
|
||||
(hasheq
|
||||
'app-title "RKT Web Player Agent"
|
||||
'server "RKT Web Player Server"
|
||||
'name "Name"
|
||||
'application-id "Anwendungs-ID"
|
||||
'playback "Wiedergabe"
|
||||
'no-track "Keine Wiedergabe"
|
||||
'no-track-selected "Kein Titel ausgewählt"
|
||||
'save-connect "Speichern und verbinden"
|
||||
'reconnect "Neu verbinden"
|
||||
'connecting "Verbinden…"
|
||||
'connected "Verbunden"
|
||||
'denied-title "Playback-Agent nicht zugelassen"
|
||||
'denied-message "Dieser Playback-Agent ist vom Server nicht zugelassen. Fügen Sie die folgende Anwendungs-ID unter [playback-agents] in die Server-INI ein:\n\n~a"
|
||||
'unauthorized-status "Nicht autorisiert — Anwendungs-ID fehlt in der Server-INI"
|
||||
'disconnected "Nicht verbunden: ~a"
|
||||
'playing "Wiedergabe"
|
||||
'paused "Pausiert"
|
||||
'loading "Laden"
|
||||
'stopped "Gestoppt"
|
||||
'channel "Kanal"
|
||||
'channels "Kanäle"
|
||||
'tray-open "RKT Web Player Agent öffnen"
|
||||
'quit "Beenden")
|
||||
'fr
|
||||
(hasheq
|
||||
'app-title "Agent RKT Web Player"
|
||||
'server "Serveur RKT Web Player"
|
||||
'name "Nom"
|
||||
'application-id "ID d’application"
|
||||
'playback "Lecture"
|
||||
'no-track "Aucune lecture en cours"
|
||||
'no-track-selected "Aucune piste sélectionnée"
|
||||
'save-connect "Enregistrer et connecter"
|
||||
'reconnect "Reconnecter"
|
||||
'connecting "Connexion…"
|
||||
'connected "Connecté"
|
||||
'denied-title "Agent de lecture non autorisé"
|
||||
'denied-message "Cet agent de lecture n’est pas autorisé par le serveur. Ajoutez l’ID d’application suivant à [playback-agents] dans le fichier INI du serveur :\n\n~a"
|
||||
'unauthorized-status "Non autorisé — l’ID d’application est absent du fichier INI du serveur"
|
||||
'disconnected "Non connecté : ~a"
|
||||
'playing "Lecture"
|
||||
'paused "En pause"
|
||||
'loading "Chargement"
|
||||
'stopped "Arrêté"
|
||||
'channel "canal"
|
||||
'channels "canaux"
|
||||
'tray-open "Ouvrir l’agent RKT Web Player"
|
||||
'quit "Quitter")
|
||||
'es
|
||||
(hasheq
|
||||
'app-title "Agente de RKT Web Player"
|
||||
'server "Servidor RKT Web Player"
|
||||
'name "Nombre"
|
||||
'application-id "ID de aplicación"
|
||||
'playback "Reproducción"
|
||||
'no-track "No se está reproduciendo nada"
|
||||
'no-track-selected "No hay ninguna pista seleccionada"
|
||||
'save-connect "Guardar y conectar"
|
||||
'reconnect "Volver a conectar"
|
||||
'connecting "Conectando…"
|
||||
'connected "Conectado"
|
||||
'denied-title "Agente de reproducción no permitido"
|
||||
'denied-message "El servidor no permite este agente de reproducción. Añade el siguiente ID de aplicación a [playback-agents] en el INI del servidor:\n\n~a"
|
||||
'unauthorized-status "No autorizado — el ID de aplicación no está en el INI del servidor"
|
||||
'disconnected "Sin conexión: ~a"
|
||||
'playing "Reproduciendo"
|
||||
'paused "En pausa"
|
||||
'loading "Cargando"
|
||||
'stopped "Detenido"
|
||||
'channel "canal"
|
||||
'channels "canales"
|
||||
'tray-open "Abrir el agente de RKT Web Player"
|
||||
'quit "Salir")
|
||||
'it
|
||||
(hasheq
|
||||
'app-title "Agente RKT Web Player"
|
||||
'server "Server RKT Web Player"
|
||||
'name "Nome"
|
||||
'application-id "ID applicazione"
|
||||
'playback "Riproduzione"
|
||||
'no-track "Nessuna riproduzione in corso"
|
||||
'no-track-selected "Nessuna traccia selezionata"
|
||||
'save-connect "Salva e connetti"
|
||||
'reconnect "Riconnetti"
|
||||
'connecting "Connessione…"
|
||||
'connected "Connesso"
|
||||
'denied-title "Agente di riproduzione non consentito"
|
||||
'denied-message "Questo agente di riproduzione non è consentito dal server. Aggiungi il seguente ID applicazione a [playback-agents] nel file INI del server:\n\n~a"
|
||||
'unauthorized-status "Non autorizzato — l’ID applicazione non è nel file INI del server"
|
||||
'disconnected "Non connesso: ~a"
|
||||
'playing "In riproduzione"
|
||||
'paused "In pausa"
|
||||
'loading "Caricamento"
|
||||
'stopped "Arrestato"
|
||||
'channel "canale"
|
||||
'channels "canali"
|
||||
'tray-open "Apri l’agente RKT Web Player"
|
||||
'quit "Esci")
|
||||
'sv
|
||||
(hasheq
|
||||
'app-title "RKT Web Player-agent"
|
||||
'server "RKT Web Player-server"
|
||||
'name "Namn"
|
||||
'application-id "Program-ID"
|
||||
'playback "Uppspelning"
|
||||
'no-track "Inget spelas upp"
|
||||
'no-track-selected "Inget spår har valts"
|
||||
'save-connect "Spara och anslut"
|
||||
'reconnect "Anslut igen"
|
||||
'connecting "Ansluter…"
|
||||
'connected "Ansluten"
|
||||
'denied-title "Uppspelningsagenten är inte tillåten"
|
||||
'denied-message "Servern tillåter inte den här uppspelningsagenten. Lägg till följande program-ID under [playback-agents] i serverns INI-fil:\n\n~a"
|
||||
'unauthorized-status "Inte behörig — program-ID saknas i serverns INI-fil"
|
||||
'disconnected "Inte ansluten: ~a"
|
||||
'playing "Spelar"
|
||||
'paused "Pausad"
|
||||
'loading "Läser in"
|
||||
'stopped "Stoppad"
|
||||
'channel "kanal"
|
||||
'channels "kanaler"
|
||||
'tray-open "Öppna RKT Web Player-agenten"
|
||||
'quit "Avsluta")
|
||||
'no
|
||||
(hasheq
|
||||
'app-title "RKT Web Player-agent"
|
||||
'server "RKT Web Player-server"
|
||||
'name "Navn"
|
||||
'application-id "Applikasjons-ID"
|
||||
'playback "Avspilling"
|
||||
'no-track "Ingenting spilles av"
|
||||
'no-track-selected "Ingen spor er valgt"
|
||||
'save-connect "Lagre og koble til"
|
||||
'reconnect "Koble til på nytt"
|
||||
'connecting "Kobler til…"
|
||||
'connected "Tilkoblet"
|
||||
'denied-title "Avspillingsagenten er ikke tillatt"
|
||||
'denied-message "Serveren tillater ikke denne avspillingsagenten. Legg til følgende applikasjons-ID under [playback-agents] i serverens INI-fil:\n\n~a"
|
||||
'unauthorized-status "Ikke autorisert — applikasjons-ID mangler i serverens INI-fil"
|
||||
'disconnected "Ikke tilkoblet: ~a"
|
||||
'playing "Spiller"
|
||||
'paused "På pause"
|
||||
'loading "Laster"
|
||||
'stopped "Stoppet"
|
||||
'channel "kanal"
|
||||
'channels "kanaler"
|
||||
'tray-open "Åpne RKT Web Player-agenten"
|
||||
'quit "Avslutt")
|
||||
'fi
|
||||
(hasheq
|
||||
'app-title "RKT Web Player -agentti"
|
||||
'server "RKT Web Player -palvelin"
|
||||
'name "Nimi"
|
||||
'application-id "Sovellustunnus"
|
||||
'playback "Toisto"
|
||||
'no-track "Mitään ei toisteta"
|
||||
'no-track-selected "Kappaletta ei ole valittu"
|
||||
'save-connect "Tallenna ja yhdistä"
|
||||
'reconnect "Yhdistä uudelleen"
|
||||
'connecting "Yhdistetään…"
|
||||
'connected "Yhdistetty"
|
||||
'denied-title "Toistoagenttia ei sallita"
|
||||
'denied-message "Palvelin ei salli tätä toistoagenttia. Lisää seuraava sovellustunnus palvelimen INI-tiedoston [playback-agents]-osioon:\n\n~a"
|
||||
'unauthorized-status "Ei valtuutettu — sovellustunnus puuttuu palvelimen INI-tiedostosta"
|
||||
'disconnected "Ei yhteyttä: ~a"
|
||||
'playing "Toistetaan"
|
||||
'paused "Keskeytetty"
|
||||
'loading "Ladataan"
|
||||
'stopped "Pysäytetty"
|
||||
'channel "kanava"
|
||||
'channels "kanavaa"
|
||||
'tray-open "Avaa RKT Web Player -agentti"
|
||||
'quit "Lopeta")
|
||||
'is
|
||||
(hasheq
|
||||
'app-title "RKT Web Player-spilari"
|
||||
'server "RKT Web Player-þjónn"
|
||||
'name "Nafn"
|
||||
'application-id "Forritsauðkenni"
|
||||
'playback "Spilun"
|
||||
'no-track "Ekkert er í spilun"
|
||||
'no-track-selected "Ekkert lag valið"
|
||||
'save-connect "Vista og tengjast"
|
||||
'reconnect "Tengjast aftur"
|
||||
'connecting "Tengist…"
|
||||
'connected "Tengt"
|
||||
'denied-title "Spilarinn er ekki leyfður"
|
||||
'denied-message "Þessi spilari er ekki leyfður af þjóninum. Bættu eftirfarandi forritsauðkenni við [playback-agents] í INI-skrá þjónsins:\n\n~a"
|
||||
'unauthorized-status "Ekki heimilað — forritsauðkenni vantar í INI-skrá þjónsins"
|
||||
'disconnected "Ekki tengt: ~a"
|
||||
'playing "Spilar"
|
||||
'paused "Í bið"
|
||||
'loading "Hleður"
|
||||
'stopped "Stöðvað"
|
||||
'channel "rás"
|
||||
'channels "rásir"
|
||||
'tray-open "Opna RKT Web Player-spilarann"
|
||||
'quit "Hætta")))
|
||||
|
||||
(define (system-language)
|
||||
(define language-name
|
||||
(string-downcase (format "~a" (system-language+country))))
|
||||
(define short-name (car (regexp-split #px"[-_]" language-name)))
|
||||
(define candidate
|
||||
(case (string->symbol short-name)
|
||||
((nb nn) 'no)
|
||||
(else (string->symbol short-name))))
|
||||
(if (hash-has-key? translation-map candidate) candidate 'en))
|
||||
|
||||
(define language (system-language))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return the supported language symbols and their native names.
|
||||
; pre : None.
|
||||
; post : Translation state remains unchanged.
|
||||
; result : An association list suitable for a language selector.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (languages)
|
||||
'((en "English")
|
||||
(nl "Nederlands")
|
||||
(de "Deutsch")
|
||||
(fr "Français")
|
||||
(es "Español")
|
||||
(it "Italiano")
|
||||
(sv "Svenska")
|
||||
(no "Norsk")
|
||||
(fi "Suomi")
|
||||
(is "Íslenska")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Select the language used by tr and __.
|
||||
; pre : Value is one of the symbols returned by languages.
|
||||
; post : Subsequent translations use value.
|
||||
; result : Void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-lang! value)
|
||||
(unless (hash-has-key? translation-map value)
|
||||
(raise-argument-error 'set-lang! "supported language symbol" value))
|
||||
(set! language value))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Report the active translation language.
|
||||
; pre : None.
|
||||
; post : Translation state remains unchanged.
|
||||
; result : A supported language symbol.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (current-lang)
|
||||
language)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Translate an application string identifier.
|
||||
; pre : Id is a symbol.
|
||||
; post : Translation state remains unchanged.
|
||||
; result : The active translation, its English fallback, or the identifier.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (tr id)
|
||||
(hash-ref (hash-ref translation-map language)
|
||||
id
|
||||
(λ ()
|
||||
(hash-ref (hash-ref translation-map 'en)
|
||||
id
|
||||
(λ () (symbol->string id))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Provide the conventional short alias used by rktplayer GUI code.
|
||||
; pre : Id is a symbol.
|
||||
; post : Translation state remains unchanged.
|
||||
; result : The same translated string as tr.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (__ id)
|
||||
(tr id))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define original-language (current-lang))
|
||||
(define english-keys
|
||||
(sort (hash-keys (hash-ref translation-map 'en)) symbol<?))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(for ((entry (in-list (languages))))
|
||||
(define candidate (car entry))
|
||||
(check-equal?
|
||||
(sort (hash-keys (hash-ref translation-map candidate)) symbol<?)
|
||||
english-keys)
|
||||
(set-lang! candidate)
|
||||
(check-true (string? (tr 'connected))))
|
||||
(set-lang! 'nl)
|
||||
(check-equal? (tr 'connected) "Verbonden")
|
||||
(set-lang! 'de)
|
||||
(check-equal? (__ 'quit) "Beenden")
|
||||
(set-lang! 'is)
|
||||
(check-equal? (tr 'connected) "Tengt")
|
||||
(check-equal? (tr 'unknown-translation) "unknown-translation")
|
||||
(check-exn exn:fail:contract? (λ () (set-lang! 'xx))))
|
||||
(λ () (set-lang! original-language))))
|
||||
+259
-158
@@ -2,7 +2,7 @@
|
||||
|
||||
(require crypto
|
||||
crypto/argon2
|
||||
net/private/ip
|
||||
net/ip
|
||||
racket/contract
|
||||
racket/list
|
||||
racket/random
|
||||
@@ -22,10 +22,16 @@
|
||||
auth-renewal-cookie
|
||||
auth-expired-cookie)
|
||||
|
||||
(struct ip-network (address prefix) #:transparent)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal data
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Holds one authenticated browser session and its two activity timestamps.
|
||||
(struct session
|
||||
(username [last-seen #:mutable] [last-cookie-renewal #:mutable])
|
||||
#:transparent)
|
||||
|
||||
;;; Holds the failed-login count and start time for one client address.
|
||||
(struct failures ([attempts #:mutable] [started #:mutable]) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -33,6 +39,8 @@
|
||||
; pre : Constructor fields contain normalized and parsed internal values.
|
||||
; post : Creating or recognizing a value does not change external state.
|
||||
; result : auth-manager? recognizes values used by the authentication API.
|
||||
; internals: users and trusted-proxies are immutable configuration references;
|
||||
; sessions and failed hold mutable login state protected by lock.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(struct auth-manager
|
||||
(users trusted-proxies session-seconds sessions failed lock)
|
||||
@@ -53,11 +61,20 @@
|
||||
(define failure-window-seconds 300)
|
||||
(define maximum-failures 5)
|
||||
|
||||
(define ipv4-mapped-prefix
|
||||
#"\0\0\0\0\0\0\0\0\0\0\377\377")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided password functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create an Argon2id password hash for configuration storage.
|
||||
; pre : Password is a string containing at least twelve characters.
|
||||
; post : No module state is changed.
|
||||
; result : A salted Argon2id hash encoded as a string.
|
||||
; internals: pwhash uses password-kdf with password-parameters to generate the
|
||||
; encoded hash, including its random salt and Argon2 parameters.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (make-password-hash password)
|
||||
(-> string? string?)
|
||||
@@ -76,125 +93,165 @@
|
||||
; pre : Password and encoded are arbitrary values.
|
||||
; post : No module state is changed.
|
||||
; result : #t only when both values are strings and the password matches.
|
||||
; internals: pwhash-verify checks the encoded Argon2id value. Malformed hashes
|
||||
; are treated as a failed match rather than escaping as exceptions.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (password-hash-valid? password encoded)
|
||||
(-> any/c any/c boolean?)
|
||||
(and (string? password)
|
||||
(string? encoded)
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(pwhash-verify password-kdf
|
||||
(string->bytes/utf-8 password)
|
||||
encoded))))
|
||||
(if (and (string? password) (string? encoded))
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(pwhash-verify password-kdf
|
||||
(string->bytes/utf-8 password)
|
||||
encoded))
|
||||
#f))
|
||||
|
||||
(define (normal-ip-bytes value)
|
||||
(define raw
|
||||
(ip-address->bytes (make-ip-address value)))
|
||||
;; Normalize IPv4-mapped IPv6 addresses to four bytes.
|
||||
(if (and (= (bytes-length raw) 16)
|
||||
(for/and ((index (in-range 10)))
|
||||
(zero? (bytes-ref raw index)))
|
||||
(= (bytes-ref raw 10) #xff)
|
||||
(= (bytes-ref raw 11) #xff))
|
||||
(subbytes raw 12)
|
||||
raw))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Parses an address and normalizes an IPv4-mapped IPv6 value to IPv4.
|
||||
(define (normal-ip-address value)
|
||||
(let* ((address (make-ip-address value))
|
||||
(raw (ip-address->bytes address))
|
||||
(ipv4-mapped?
|
||||
(and (= (bytes-length raw) 16)
|
||||
(bytes=? (subbytes raw 0 12) ipv4-mapped-prefix))))
|
||||
(if ipv4-mapped?
|
||||
(bytes->ipv4-address (subbytes raw 12))
|
||||
address)))
|
||||
|
||||
;;; Parses one configured IP address or CIDR value as a public net/ip network.
|
||||
(define (parse-network value)
|
||||
(define parts (string-split (string-trim value) "/"))
|
||||
(unless (member (length parts) '(1 2))
|
||||
(raise-argument-error 'make-auth-manager "IP address or CIDR network" value))
|
||||
(define address
|
||||
(with-handlers ((exn:fail?
|
||||
(λ (_)
|
||||
(raise-argument-error
|
||||
'make-auth-manager
|
||||
"IP address or CIDR network"
|
||||
value))))
|
||||
(normal-ip-bytes (car parts))))
|
||||
(define maximum (* 8 (bytes-length address)))
|
||||
(define prefix
|
||||
(if (= (length parts) 2)
|
||||
(string->number (cadr parts))
|
||||
maximum))
|
||||
(unless (and (exact-nonnegative-integer? prefix)
|
||||
(<= prefix maximum))
|
||||
(raise-argument-error 'make-auth-manager "IP address or CIDR network" value))
|
||||
(ip-network address prefix))
|
||||
(let ((parts (string-split (string-trim value) "/")))
|
||||
(unless (member (length parts) '(1 2))
|
||||
(raise-argument-error
|
||||
'make-auth-manager
|
||||
"IP address or CIDR network"
|
||||
value))
|
||||
(let* ((address
|
||||
(with-handlers ((exn:fail?
|
||||
(λ (_)
|
||||
(raise-argument-error
|
||||
'make-auth-manager
|
||||
"IP address or CIDR network"
|
||||
value))))
|
||||
(normal-ip-address (car parts))))
|
||||
(maximum (ip-address-size address))
|
||||
(prefix
|
||||
(if (= (length parts) 2)
|
||||
(string->number (cadr parts))
|
||||
maximum)))
|
||||
(unless (and (exact-nonnegative-integer? prefix)
|
||||
(<= prefix maximum))
|
||||
(raise-argument-error
|
||||
'make-auth-manager
|
||||
"IP address or CIDR network"
|
||||
value))
|
||||
(make-network address prefix))))
|
||||
|
||||
;;; Checks whether an address belongs to one configured trusted network.
|
||||
(define (network-contains? network address-string)
|
||||
(with-handlers ((exn:fail? (λ (_) #f)))
|
||||
(define candidate (normal-ip-bytes address-string))
|
||||
(define expected (ip-network-address network))
|
||||
(and (= (bytes-length candidate) (bytes-length expected))
|
||||
(let-values (((whole remainder)
|
||||
(quotient/remainder (ip-network-prefix network) 8)))
|
||||
(and (for/and ((index (in-range whole)))
|
||||
(= (bytes-ref candidate index)
|
||||
(bytes-ref expected index)))
|
||||
(or (zero? remainder)
|
||||
(let ((mask
|
||||
(bitwise-and #xff
|
||||
(arithmetic-shift #xff (- remainder 8)))))
|
||||
(= (bitwise-and (bytes-ref candidate whole) mask)
|
||||
(bitwise-and (bytes-ref expected whole) mask)))))))))
|
||||
(network-member network (normal-ip-address address-string))))
|
||||
|
||||
;;; Reads one request header as a UTF-8 string when present.
|
||||
(define (header-string request name)
|
||||
(let ((value (headers-assq* name (request-headers/raw request))))
|
||||
(and value
|
||||
(bytes->string/utf-8 (header-value value)))))
|
||||
|
||||
;;; Checks whether an address belongs to any configured trusted proxy network.
|
||||
(define (trusted-proxy? manager address)
|
||||
(ormap (λ (network) (network-contains? network address))
|
||||
(auth-manager-trusted-proxies manager)))
|
||||
|
||||
;;; Resolves the effective client address, honoring only a trusted proxy header.
|
||||
(define (request-address manager request)
|
||||
(define peer (request-client-ip request))
|
||||
(define forwarded
|
||||
(and (trusted-proxy? manager peer)
|
||||
(header-string request #"X-Forwarded-For")))
|
||||
(if forwarded
|
||||
;; A trusted reverse proxy appends the address it observed. Earlier
|
||||
;; values can have been supplied by the untrusted client.
|
||||
(string-trim (last (string-split forwarded ",")))
|
||||
peer))
|
||||
(let* ((peer (request-client-ip request))
|
||||
(forwarded
|
||||
(and (trusted-proxy? manager peer)
|
||||
(header-string request #"X-Forwarded-For"))))
|
||||
(if forwarded
|
||||
;; A trusted reverse proxy appends the address it observed. Earlier
|
||||
;; values can have been supplied by the untrusted client.
|
||||
(string-trim (last (string-split forwarded ",")))
|
||||
peer)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Extracts the session token from the request cookies when present.
|
||||
(define (request-session-token request)
|
||||
(let ((cookie
|
||||
(findf
|
||||
(λ (value)
|
||||
(string=? (client-cookie-name value) session-cookie-name))
|
||||
(request-cookies request))))
|
||||
(if cookie
|
||||
(client-cookie-value cookie)
|
||||
#f)))
|
||||
|
||||
;;; Removes every browser session whose idle lifetime has elapsed.
|
||||
(define (prune-sessions! manager now)
|
||||
(for-each
|
||||
(λ (token)
|
||||
(let ((value (hash-ref (auth-manager-sessions manager) token)))
|
||||
(when (> (- now (session-last-seen value))
|
||||
(auth-manager-session-seconds manager))
|
||||
(hash-remove! (auth-manager-sessions manager) token))))
|
||||
(hash-keys (auth-manager-sessions manager))))
|
||||
|
||||
;;; Checks and, when necessary, resets the failure window for one address.
|
||||
(define (failure-blocked? manager address now)
|
||||
(let ((value (hash-ref (auth-manager-failed manager) address #f)))
|
||||
(cond
|
||||
((eq? value #f) #f)
|
||||
((> (- now (failures-started value)) failure-window-seconds)
|
||||
(hash-remove! (auth-manager-failed manager) address)
|
||||
#f)
|
||||
(else
|
||||
(>= (failures-attempts value) maximum-failures)))))
|
||||
|
||||
;;; Adds one failed login to the current address window or starts a new window.
|
||||
(define (record-failure! manager address now)
|
||||
(let ((value (hash-ref (auth-manager-failed manager) address #f)))
|
||||
(if (and value
|
||||
(<= (- now (failures-started value)) failure-window-seconds))
|
||||
(set-failures-attempts! value (add1 (failures-attempts value)))
|
||||
(hash-set! (auth-manager-failed manager)
|
||||
address
|
||||
(failures 1 now)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided authentication functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Report whether browser authentication is configured.
|
||||
; pre : Manager is an auth-manager.
|
||||
; post : Manager remains unchanged.
|
||||
; result : #t when at least one configured user can log in, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-enabled? manager)
|
||||
(-> auth-manager? boolean?)
|
||||
(positive? (hash-count (auth-manager-users manager))))
|
||||
|
||||
(define (request-session-token request)
|
||||
(for/or ((cookie (in-list (request-cookies request))))
|
||||
(and (string=? (client-cookie-name cookie) session-cookie-name)
|
||||
(client-cookie-value cookie))))
|
||||
|
||||
(define (prune-sessions! manager now)
|
||||
(for ((token (in-list (hash-keys (auth-manager-sessions manager)))))
|
||||
(let ((value (hash-ref (auth-manager-sessions manager) token)))
|
||||
(when (> (- now (session-last-seen value))
|
||||
(auth-manager-session-seconds manager))
|
||||
(hash-remove! (auth-manager-sessions manager) token)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the browser user represented by a request cookie.
|
||||
; pre : Manager is an auth-manager and request is an HTTP request.
|
||||
; post : Expired sessions are removed and a valid session's last-seen time
|
||||
; is updated.
|
||||
; result : "anonymous" when authentication is disabled, the normalized
|
||||
; username for a valid session, or #f when login is required.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; internals: request-session-token finds the cookie. The manager lock protects
|
||||
; prune-sessions! and the session lookup; a valid lookup updates its
|
||||
; idle timestamp before returning the stored username.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-request-user manager request)
|
||||
(-> auth-manager? request? (or/c #f string?))
|
||||
(cond
|
||||
((not (auth-enabled? manager)) "anonymous")
|
||||
(else
|
||||
(let ((token (request-session-token request))
|
||||
(now (current-seconds)))
|
||||
(and token
|
||||
(if (not (auth-enabled? manager))
|
||||
"anonymous"
|
||||
(let ((token (request-session-token request))
|
||||
(now (current-seconds)))
|
||||
(if (eq? token #f)
|
||||
#f
|
||||
(call-with-semaphore
|
||||
(auth-manager-lock manager)
|
||||
(λ ()
|
||||
@@ -202,28 +259,11 @@
|
||||
(let ((value (hash-ref (auth-manager-sessions manager)
|
||||
token
|
||||
#f)))
|
||||
(and value
|
||||
(begin
|
||||
(set-session-last-seen! value now)
|
||||
(session-username value)))))))))))
|
||||
|
||||
(define (failure-blocked? manager address now)
|
||||
(define value (hash-ref (auth-manager-failed manager) address #f))
|
||||
(and value
|
||||
(if (> (- now (failures-started value)) failure-window-seconds)
|
||||
(begin
|
||||
(hash-remove! (auth-manager-failed manager) address)
|
||||
#f)
|
||||
(>= (failures-attempts value) maximum-failures))))
|
||||
|
||||
(define (record-failure! manager address now)
|
||||
(define value (hash-ref (auth-manager-failed manager) address #f))
|
||||
(if (and value
|
||||
(<= (- now (failures-started value)) failure-window-seconds))
|
||||
(set-failures-attempts! value (+ 1 (failures-attempts value)))
|
||||
(hash-set! (auth-manager-failed manager)
|
||||
address
|
||||
(failures 1 now))))
|
||||
(if value
|
||||
(begin
|
||||
(set-session-last-seen! value now)
|
||||
(session-username value))
|
||||
#f))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Authenticate credentials and start a browser session.
|
||||
@@ -232,8 +272,11 @@
|
||||
; post : A valid login creates a new session; a failed login updates the
|
||||
; rate-limit state for the effective client address.
|
||||
; result : A new opaque token, #f for invalid credentials, or 'rate-limited.
|
||||
; internals: Unknown users follow the same Argon2id verification path as known
|
||||
; users to reduce username-dependent timing differences.
|
||||
; internals: request-address selects the rate-limit key and failure-blocked?
|
||||
; checks its window while the manager lock is held. Unknown users
|
||||
; verify against dummy-password-hash to reduce username-dependent
|
||||
; timing differences. Success creates a session; failure delegates
|
||||
; to record-failure!.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-login! manager request username password)
|
||||
(-> auth-manager?
|
||||
@@ -274,6 +317,8 @@
|
||||
; pre : Manager is an auth-manager and request is an HTTP request.
|
||||
; post : The matching server-side session is removed when it exists.
|
||||
; result : Void.
|
||||
; internals: request-session-token finds the cookie and the manager lock
|
||||
; protects removal from the shared session hash.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-logout! manager request)
|
||||
(-> auth-manager? request? void?)
|
||||
@@ -290,6 +335,8 @@
|
||||
; post : Manager remains unchanged.
|
||||
; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value whose Max-Age
|
||||
; equals the configured session lifetime.
|
||||
; internals: format combines session-cookie-name, token and the manager's
|
||||
; configured lifetime into the complete Set-Cookie header value.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-session-cookie manager token)
|
||||
(-> auth-manager? string? bytes?)
|
||||
@@ -307,37 +354,48 @@
|
||||
; last-cookie-renewal time is advanced.
|
||||
; result : A fresh Set-Cookie value after half the configured lifetime has
|
||||
; elapsed, otherwise #f.
|
||||
; internals: The server idle timer moves on every authenticated request, while
|
||||
; this half-life threshold prevents the one-second player poll from
|
||||
; returning Set-Cookie every second.
|
||||
; internals: request-session-token identifies the session. The manager lock
|
||||
; protects prune-sessions! and the renewal timestamp. A half-life
|
||||
; threshold prevents the one-second player poll from returning a
|
||||
; new cookie every second.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-renewal-cookie manager request)
|
||||
(-> auth-manager? request? (or/c #f bytes?))
|
||||
(and (auth-enabled? manager)
|
||||
(let ((token (request-session-token request))
|
||||
(now (current-seconds)))
|
||||
(and token
|
||||
(call-with-semaphore
|
||||
(auth-manager-lock manager)
|
||||
(λ ()
|
||||
(prune-sessions! manager now)
|
||||
(let ((value
|
||||
(hash-ref (auth-manager-sessions manager) token #f)))
|
||||
(and value
|
||||
(>= (- now (session-last-cookie-renewal value))
|
||||
(max 1
|
||||
(quotient
|
||||
(auth-manager-session-seconds manager)
|
||||
2)))
|
||||
(begin
|
||||
(set-session-last-cookie-renewal! value now)
|
||||
(auth-session-cookie manager token))))))))))
|
||||
(if (not (auth-enabled? manager))
|
||||
#f
|
||||
(let ((token (request-session-token request))
|
||||
(now (current-seconds)))
|
||||
(if (eq? token #f)
|
||||
#f
|
||||
(call-with-semaphore
|
||||
(auth-manager-lock manager)
|
||||
(λ ()
|
||||
(prune-sessions! manager now)
|
||||
(let ((value
|
||||
(hash-ref (auth-manager-sessions manager) token #f)))
|
||||
(if value
|
||||
(let* ((elapsed
|
||||
(- now
|
||||
(session-last-cookie-renewal value)))
|
||||
(renewal-interval
|
||||
(max 1
|
||||
(quotient
|
||||
(auth-manager-session-seconds manager)
|
||||
2))))
|
||||
(if (< elapsed renewal-interval)
|
||||
#f
|
||||
(begin
|
||||
(set-session-last-cookie-renewal! value now)
|
||||
(auth-session-cookie manager token))))
|
||||
#f))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Encode deletion of the browser session cookie.
|
||||
; pre : None.
|
||||
; post : No module state is changed.
|
||||
; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value with Max-Age 0.
|
||||
; internals: format uses session-cookie-name and an empty value to instruct the
|
||||
; browser to remove the cookie immediately.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (auth-expired-cookie)
|
||||
(-> bytes?)
|
||||
@@ -354,6 +412,10 @@
|
||||
; post : No external state is changed; session and rate-limit tables start
|
||||
; empty.
|
||||
; result : A new auth-manager with normalized usernames and parsed networks.
|
||||
; internals: Each user entry is validated and copied into a case-insensitive
|
||||
; hash. parse-network converts trusted-proxy-values through the
|
||||
; public net/ip API; fresh hashes and a semaphore protect sessions
|
||||
; and failed-login windows.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (make-auth-manager
|
||||
user-pairs
|
||||
@@ -367,33 +429,33 @@
|
||||
(unless (exact-positive-integer? session-seconds)
|
||||
(raise-argument-error 'make-auth-manager "exact-positive-integer?"
|
||||
session-seconds))
|
||||
(define users (make-hash))
|
||||
(for ((entry (in-list user-pairs)))
|
||||
(unless (and (pair? entry)
|
||||
(string? (car entry))
|
||||
(string? (cdr entry)))
|
||||
(raise-argument-error
|
||||
'make-auth-manager
|
||||
"(listof (cons/c string? string?))"
|
||||
user-pairs))
|
||||
(when (string=? (string-trim (car entry)) "")
|
||||
(raise-arguments-error
|
||||
'make-auth-manager
|
||||
"username must not be empty"
|
||||
"username" (car entry)))
|
||||
(unless (regexp-match? #px"^[$]argon2id[$]" (cdr entry))
|
||||
(raise-arguments-error
|
||||
'make-auth-manager
|
||||
"user password is not an Argon2id hash"
|
||||
"username" (car entry)))
|
||||
(hash-set! users (string-downcase (string-trim (car entry)))
|
||||
(cdr entry)))
|
||||
(auth-manager users
|
||||
(map parse-network trusted-proxy-values)
|
||||
session-seconds
|
||||
(make-hash)
|
||||
(make-hash)
|
||||
(make-semaphore 1)))
|
||||
(let ((users (make-hash)))
|
||||
(for-each
|
||||
(λ (entry)
|
||||
(let ((username (string-trim (car entry)))
|
||||
(password-hash (cdr entry)))
|
||||
(when (string=? username "")
|
||||
(raise-arguments-error
|
||||
'make-auth-manager
|
||||
"username must not be empty"
|
||||
"username" (car entry)))
|
||||
(unless (regexp-match? #px"^[$]argon2id[$]" password-hash)
|
||||
(raise-arguments-error
|
||||
'make-auth-manager
|
||||
"user password is not an Argon2id hash"
|
||||
"username" (car entry)))
|
||||
(hash-set! users (string-downcase username) password-hash)))
|
||||
user-pairs)
|
||||
(auth-manager users
|
||||
(map parse-network trusted-proxy-values)
|
||||
session-seconds
|
||||
(make-hash)
|
||||
(make-hash)
|
||||
(make-semaphore 1))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tests for module users.rkt
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(require net/url
|
||||
@@ -410,6 +472,20 @@
|
||||
(list (cons "Hans" test-hash))
|
||||
#:trusted-proxies '("127.0.0.1/32")))
|
||||
|
||||
(check-true
|
||||
(network-contains? (parse-network "192.0.2.0/24") "192.0.2.18"))
|
||||
(check-false
|
||||
(network-contains? (parse-network "192.0.2.0/24") "192.0.3.18"))
|
||||
(check-true
|
||||
(network-contains? (parse-network "2001:db8::/32") "2001:db8::12"))
|
||||
(check-true
|
||||
(network-contains? (parse-network "127.0.0.0/8")
|
||||
"0:0:0:0:0:ffff:7f00:1"))
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (parse-network "192.0.2.1/33")))
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (parse-network "not-an-address")))
|
||||
|
||||
(define (test-request peer [headers '()])
|
||||
(request #"GET" (string->url "http://example.test/api/state")
|
||||
headers (delay '()) #f "127.0.0.1" 80 peer))
|
||||
@@ -432,6 +508,13 @@
|
||||
"198.51.100.2"
|
||||
(list (header #"X-Forwarded-For" #"203.0.113.9"))))
|
||||
"198.51.100.2")
|
||||
(check-equal?
|
||||
(request-address
|
||||
manager
|
||||
(test-request
|
||||
"0:0:0:0:0:ffff:7f00:1"
|
||||
(list (header #"X-Forwarded-For" #"203.0.113.9"))))
|
||||
"203.0.113.9")
|
||||
(define token
|
||||
(auth-login! manager remote "hans" "correct horse battery staple"))
|
||||
(check-true (string? token))
|
||||
@@ -451,4 +534,22 @@
|
||||
(check-false (auth-renewal-cookie manager authenticated))
|
||||
(auth-logout! manager authenticated)
|
||||
(check-false (auth-request-user manager authenticated))
|
||||
(check-false (auth-login! manager remote "hans" "wrong password")))
|
||||
(check-false (auth-login! manager remote "hans" "wrong password"))
|
||||
|
||||
(let ((limited-manager (make-auth-manager '())))
|
||||
(for-each
|
||||
(λ (_) (record-failure! limited-manager "192.0.2.1" 100))
|
||||
(range maximum-failures))
|
||||
(check-true (failure-blocked? limited-manager "192.0.2.1" 100))
|
||||
(check-false
|
||||
(failure-blocked? limited-manager
|
||||
"192.0.2.1"
|
||||
(+ 101 failure-window-seconds))))
|
||||
|
||||
(let ((session-manager (make-auth-manager '() #:session-seconds 10)))
|
||||
(hash-set! (auth-manager-sessions session-manager)
|
||||
"expired"
|
||||
(session "hans" 0 0))
|
||||
(prune-sessions! session-manager 11)
|
||||
(check-false
|
||||
(hash-has-key? (auth-manager-sessions session-manager) "expired"))))
|
||||
|
||||
Reference in New Issue
Block a user