396 lines
14 KiB
Racket
396 lines
14 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/place
|
|
racket/contract
|
|
racket/async-channel
|
|
racket/runtime-path
|
|
racket/string
|
|
"audio-errors.rkt"
|
|
uni-channel
|
|
"audio-placed-player.rkt"
|
|
"opusfile-decoder.rkt"
|
|
"private/utils.rkt"
|
|
"private/remote-utils.rkt"
|
|
(prefix-in ffi: ffi/unsafe)
|
|
)
|
|
|
|
(provide make-audio-player
|
|
audio-play!
|
|
audio-pause!
|
|
audio-paused?
|
|
audio-stop!
|
|
audio-quit!
|
|
audio-seek!
|
|
audio-volume!
|
|
audio-volume
|
|
audio-at-second
|
|
audio-duration
|
|
audio-state
|
|
audio-bits
|
|
audio-channels
|
|
audio-decoder
|
|
audio-music-id
|
|
audio-rate
|
|
audio-full-state
|
|
audio-file
|
|
audio-play?
|
|
audio-buf-seconds!
|
|
audio-ao-buf-ms!
|
|
audio-ao-buf-ms
|
|
audio-known-exts?
|
|
audio-parameterize!
|
|
audio-param!
|
|
audio-param
|
|
replace-base-path
|
|
)
|
|
|
|
(define-runtime-path placed-player-module "audio-placed-player.rkt")
|
|
|
|
|
|
(define-struct audio-play
|
|
(valid? cb-state cb-eof-stream rpc au-place evt-thread state replace-base-paths)
|
|
#:mutable
|
|
#:transparent
|
|
)
|
|
|
|
(define audio-play-struct? audio-play?)
|
|
(set! audio-play? (λ (h)
|
|
(and (audio-play-struct? h)
|
|
(audio-play-valid? h))))
|
|
|
|
|
|
(define (percentage? p)
|
|
(and (number? p) (>= p 0)))
|
|
|
|
(define (any? x)
|
|
#t)
|
|
|
|
(define (max-percentage? n)
|
|
(λ (p) (and (percentage? p)
|
|
(<= p n))))
|
|
|
|
(define (is-return? retval sym)
|
|
(if (list? retval)
|
|
(if (null? retval)
|
|
#f
|
|
(eq? (car retval) sym))
|
|
#f))
|
|
|
|
(define-struct internal-audio-retval
|
|
(kind code info retval)
|
|
#:transparent
|
|
)
|
|
|
|
(define (to-ret-value ret)
|
|
(if (list? ret)
|
|
(if (null? ret)
|
|
(raise-audio-error 'audio-error "audio-player: no return value, empty list returned")
|
|
(let ((r (car ret)))
|
|
(if (eq? r 'error)
|
|
(let ((msg (cadr ret))
|
|
(code (caddr ret)))
|
|
(err-sound "Got an error: ~a - ~a" code msg)
|
|
(make-internal-audio-retval 'error code msg 'error))
|
|
(make-internal-audio-retval 'retval #f #f r))))
|
|
(if (eq? ret 'error)
|
|
(make-internal-audio-retval 'error 'audio-error "An undefined error was raised in the audio-player" 'error)
|
|
(make-internal-audio-retval 'retval #f #f ret))))
|
|
|
|
(define (is-event? evt sym)
|
|
(is-return? evt sym))
|
|
|
|
(define (evt-data evt)
|
|
(cadr evt))
|
|
|
|
(define (correct-to-os-path h replacements)
|
|
(let ((file (hash-ref h 'file #f)))
|
|
(letrec ((f (λ (l fl)
|
|
(if (null? l)
|
|
fl
|
|
(let ((bp-remote (cdar l))
|
|
(bp-local (caar l)))
|
|
(f (cdr l) (string-replace fl bp-remote bp-local)))))))
|
|
(unless (eq? file #f)
|
|
(let* ((delim (if (eq? (system-type 'os) 'windows) "\\" "/"))
|
|
(file* (string-replace
|
|
(string-replace
|
|
(f replacements (format "~a" file)) "/" delim)
|
|
"\\" delim)))
|
|
(hash-set! h 'file (build-path file*))))
|
|
h)))
|
|
|
|
(define-syntax assert
|
|
(syntax-rules ()
|
|
((_ cond message ...)
|
|
(unless cond (error (format message ...))))))
|
|
|
|
(define/contract (make-audio-player cb-state cb-eof-stream
|
|
#:use-place [use-place (place-enabled?)]
|
|
#:remote-host [remote-host #f]
|
|
#:replace-base-paths [replace-base-paths '()])
|
|
(->* (procedure? procedure?)
|
|
(#:use-place boolean?
|
|
#:remote-host (or/c #f string?)
|
|
#:replace-base-paths replace-base-paths?)
|
|
audio-play?)
|
|
(let ((cmd-ch #f)
|
|
(ret-ch #f)
|
|
(evt-ch #f)
|
|
(cmd-put #f)
|
|
(ret-get #f)
|
|
(evt-get #f)
|
|
(au-pl #f)
|
|
(dead-guard #f)
|
|
(rpc #f)
|
|
(rpc-mutex (make-mutex))
|
|
)
|
|
(cond
|
|
[remote-host
|
|
;; Remote mode is deliberately narrow: make-audio-player only needs
|
|
;; a host and optional base-path replacements. SSH, Racket and module
|
|
;; details are encapsulated in private/remote-utils.rkt and its config.
|
|
(let-values (((cmd-ch* ret-ch* evt-ch* proc dead-guard*)
|
|
(start-remote-placed-player remote-host)))
|
|
(set! cmd-ch cmd-ch*)
|
|
(set! ret-ch ret-ch*)
|
|
(set! evt-ch evt-ch*)
|
|
(set! au-pl proc)
|
|
(set! dead-guard dead-guard*))]
|
|
[use-place
|
|
;; dynamic-place returns the command place-channel. The raw channel
|
|
;; is kept for place-dead-evt, while normal traffic is sent through
|
|
;; a uni-channel wrapper.
|
|
(let ((raw-cmd-ch (dynamic-place placed-player-module 'placed-player)))
|
|
(set! cmd-ch (make-uni-channel raw-cmd-ch))
|
|
(set! au-pl raw-cmd-ch)
|
|
(set! dead-guard (lambda () (let ((evt (place-dead-evt au-pl)))
|
|
(sync evt))))
|
|
(let-values (((ret-ch-in ret-ch-out) (place-channel))
|
|
((evt-ch-in evt-ch-out) (place-channel)))
|
|
;; Do not send uni-channel structs through a place-channel: they
|
|
;; contain procedures and are not place-message values. Send the
|
|
;; raw channels and let the worker wrap them on its own side.
|
|
(set! ret-ch (make-uni-channel ret-ch-in))
|
|
(set! evt-ch (make-uni-channel evt-ch-in))
|
|
(uni-channel-put cmd-ch (list 'init ret-ch-out evt-ch-out))
|
|
(assert (is-return? (uni-channel-get ret-ch) 'initialized)
|
|
"Unexpected: not 'initialized returned from 'init command")))]
|
|
[else
|
|
(let ((raw-cmd-ch (make-async-channel)))
|
|
(set! cmd-ch (make-uni-channel raw-cmd-ch))
|
|
(set! au-pl (thread (lambda () (placed-player raw-cmd-ch))))
|
|
(set! dead-guard (lambda () (let ((evt (thread-dead-evt au-pl)))
|
|
(sync evt))))
|
|
(let ((raw-ret-ch (make-async-channel))
|
|
(raw-evt-ch (make-async-channel)))
|
|
;; As in place mode, pass raw channels during init and keep
|
|
;; uni-channel wrappers on each side for all subsequent traffic.
|
|
(set! ret-ch (make-uni-channel raw-ret-ch))
|
|
(set! evt-ch (make-uni-channel raw-evt-ch))
|
|
(uni-channel-put cmd-ch (list 'init raw-ret-ch raw-evt-ch))
|
|
(assert (is-return? (uni-channel-get ret-ch) 'initialized)
|
|
"Unexpected: not 'initialized returned from 'init command")))])
|
|
(set! cmd-put (λ (data) (uni-channel-put cmd-ch data)))
|
|
(set! ret-get (λ () (to-ret-value (uni-channel-get ret-ch))))
|
|
(set! evt-get (λ (timeout-ms) (sync/timeout (/ timeout-ms 1000)
|
|
(uni-channel-get-evt evt-ch))))
|
|
(set! rpc (lambda (cmd . args)
|
|
(with-mutex rpc-mutex
|
|
(define args*
|
|
(if (and (eq? cmd 'open) (pair? args))
|
|
(cons (replace-base-path (car args) replace-base-paths) (cdr args))
|
|
args))
|
|
(cmd-put (cons cmd args*))
|
|
(ret-get))))
|
|
|
|
(let* ((handle #f)
|
|
(cb-state* (λ (st st-hash) (cb-state handle st st-hash)))
|
|
(cb-eof* (λ () (cb-eof-stream handle))))
|
|
(set! handle (make-audio-play #t
|
|
cb-state* cb-eof*
|
|
rpc
|
|
au-pl
|
|
#f
|
|
(make-hash)
|
|
replace-base-paths))
|
|
(set-audio-play-evt-thread! handle
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(if (audio-play-valid? handle)
|
|
(let ((e (evt-get 500)))
|
|
(cond ((eq? e #f) (void))
|
|
((is-event? e 'state)
|
|
(let* ((data (evt-data e))
|
|
(h (hash-copy (car data))))
|
|
(correct-to-os-path h replace-base-paths)
|
|
(set-audio-play-state! handle h)
|
|
(cb-state* (cadr data) h)))
|
|
((is-event? e 'audio-done) (cb-eof*))
|
|
((is-event? e 'exception)
|
|
(err-sound "audio-player: exception event: ~a" e))
|
|
(else (warn-sound "audio-player: unknown event ~a" e))
|
|
)
|
|
(loop))
|
|
'done)))))
|
|
|
|
(thread (λ ()
|
|
(dbg-sound "guarding audio-placed-player")
|
|
(dead-guard)
|
|
(dbg-sound "audio-placed-player has stopped")
|
|
(set-audio-play-valid?! handle #f)
|
|
(set-audio-play-rpc! handle #f)
|
|
(set-audio-play-au-place! handle #f)
|
|
(set-audio-play-evt-thread! handle #f)
|
|
(set-audio-play-cb-state! handle #f)
|
|
(set-audio-play-cb-eof-stream! handle #f)
|
|
(when (hash? (audio-play-state handle))
|
|
(let ((h (hash-copy (audio-play-state handle))))
|
|
(hash-set! h 'state 'invalid)
|
|
(correct-to-os-path h replace-base-paths)
|
|
(set-audio-play-state! handle h)))
|
|
(dbg-sound "audio-play handle invalidated and cleaned of references")
|
|
))
|
|
|
|
(ffi:register-finalizer handle
|
|
(λ (h)
|
|
(when (audio-play? h)
|
|
(rpc 'quit))))
|
|
|
|
(audio-parameterize! handle)
|
|
handle)
|
|
)
|
|
)
|
|
|
|
(define-syntax ap-rpc
|
|
(syntax-rules ()
|
|
((_ handle cmd args ...)
|
|
(let ((rv ((audio-play-rpc handle) cmd args ...)))
|
|
(if (eq? (internal-audio-retval-kind rv) 'error)
|
|
(raise-audio-error (internal-audio-retval-code rv) (internal-audio-retval-info rv))
|
|
(internal-audio-retval-retval rv))))
|
|
)
|
|
)
|
|
|
|
(define/contract (audio-play! handle audio-file)
|
|
(-> audio-play? path-string? number?)
|
|
(let ((r (ap-rpc handle 'open audio-file)))
|
|
(if (eq? (car r) 'ok)
|
|
(cadr r)
|
|
(raise-audio-error 'audio-error "audio-play!: unexpected return value from 'open command: ~a" r))))
|
|
|
|
(define/contract (audio-pause! handle paused)
|
|
(-> audio-play? boolean? symbol?)
|
|
(ap-rpc handle 'pause paused))
|
|
|
|
(define/contract (audio-paused? handle)
|
|
(-> audio-play? boolean?)
|
|
(ap-rpc handle 'paused))
|
|
|
|
(define/contract (audio-stop! handle)
|
|
(-> audio-play? symbol?)
|
|
(ap-rpc handle 'stop))
|
|
|
|
(define/contract (audio-quit! handle)
|
|
(-> audio-play? (or/c number? boolean? symbol?))
|
|
(let ((r (ap-rpc handle 'quit)))
|
|
(set-audio-play-valid?! handle #f)
|
|
r))
|
|
|
|
(define/contract (audio-seek! handle percentage)
|
|
(-> audio-play? (max-percentage? 100) symbol?)
|
|
(ap-rpc handle 'seek percentage))
|
|
|
|
(define/contract (audio-volume! handle percentage)
|
|
(-> audio-play? percentage? symbol?)
|
|
(ap-rpc handle 'volume percentage))
|
|
|
|
(define/contract (audio-volume handle)
|
|
(-> audio-play? percentage?)
|
|
(ap-rpc handle 'get-volume))
|
|
|
|
(define/contract (audio-full-state handle)
|
|
(-> audio-play? hash?)
|
|
(audio-play-state handle))
|
|
|
|
(define-syntax get-state
|
|
(syntax-rules ()
|
|
((_ handle id def)
|
|
(hash-ref (audio-play-state handle) id def))))
|
|
|
|
(define/contract (audio-at-second handle)
|
|
(-> audio-play? (or/c number? boolean?))
|
|
(get-state handle 'at-second #f))
|
|
|
|
(define/contract (audio-duration handle)
|
|
(-> audio-play? (or/c number? boolean?))
|
|
(get-state handle 'duration #f))
|
|
|
|
(define/contract (audio-channels handle)
|
|
(-> audio-play? (or/c number? boolean?))
|
|
(get-state handle 'channels #f))
|
|
|
|
(define/contract (audio-state handle)
|
|
(-> audio-play-struct? symbol?)
|
|
(if (audio-play-valid? handle)
|
|
(get-state handle 'state 'initialized)
|
|
'invalid))
|
|
|
|
(define/contract (audio-bits handle)
|
|
(-> audio-play? (or/c number? boolean?))
|
|
(get-state handle 'bits #f))
|
|
|
|
(define/contract (audio-rate handle)
|
|
(-> audio-play? (or/c number? boolean?))
|
|
(get-state handle 'rate #f))
|
|
|
|
(define/contract (audio-decoder handle)
|
|
(-> audio-play? (or/c symbol? boolean?))
|
|
(get-state handle 'decoder #f))
|
|
|
|
(define/contract (audio-music-id handle)
|
|
(-> audio-play? (or/c number? boolean?))
|
|
(get-state handle 'at-music-id #f))
|
|
|
|
(define/contract (audio-file handle)
|
|
(-> audio-play? (or/c path-string? boolean?))
|
|
(get-state handle 'file #f))
|
|
|
|
(define/contract (audio-buf-seconds! handle min max)
|
|
(-> audio-play? number? number? (or/c symbol? boolean?))
|
|
(let ((from (if (< min 1) 1 (if (> min 10) 10 min)))
|
|
(until (if (< max min) (+ min 1) (if (> max 30) 30 max))))
|
|
(ap-rpc handle 'buf-seconds from until)))
|
|
|
|
(define/contract (audio-ao-buf-ms! handle ms)
|
|
(-> audio-play? integer? (or/c integer? boolean?))
|
|
(ap-rpc handle 'ao-buf-ms ms))
|
|
|
|
(define/contract (audio-ao-buf-ms handle)
|
|
(-> audio-play? (or/c integer? boolean?))
|
|
(ap-rpc handle 'ao-buf-ms))
|
|
|
|
(define/contract (audio-param! handle param value)
|
|
(-> audio-play? symbol? any? any?)
|
|
(ap-rpc handle 'param! param value))
|
|
|
|
(define/contract (audio-param handle param)
|
|
(-> audio-play? symbol? any?)
|
|
(ap-rpc handle 'param param))
|
|
|
|
(define/contract (audio-parameterize! handle)
|
|
(-> audio-play? void?)
|
|
(void
|
|
(let* ((opus-fmt (current-opusfile-output-format))
|
|
(opus-bits (if (eq? opus-fmt 's24) 24 16))
|
|
)
|
|
(audio-param! handle 'opus-bits opus-bits)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
|
|
|
|
|