Remote usage of audio-placed-player.rkt
This commit is contained in:
+96
-36
@@ -4,8 +4,10 @@
|
||||
racket/contract
|
||||
racket/async-channel
|
||||
racket/runtime-path
|
||||
uni-channel
|
||||
"audio-placed-player.rkt"
|
||||
"private/utils.rkt"
|
||||
"private/remote-utils.rkt"
|
||||
(prefix-in ffi: ffi/unsafe)
|
||||
)
|
||||
|
||||
@@ -35,12 +37,22 @@
|
||||
audio-known-exts?
|
||||
audio-param!
|
||||
audio-param
|
||||
audio-remote-path
|
||||
racket-sound-default-ssh-program
|
||||
racket-sound-default-ssh-options
|
||||
racket-sound-default-remote-racket
|
||||
racket-sound-default-remote-module
|
||||
racket-sound-default-remote-command
|
||||
current-racket-sound-ssh-program
|
||||
current-racket-sound-remote-racket
|
||||
current-racket-sound-remote-module
|
||||
)
|
||||
|
||||
(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)
|
||||
(valid? cb-state cb-eof-stream rpc au-place evt-thread state remote-path-map)
|
||||
#:mutable
|
||||
#:transparent
|
||||
)
|
||||
@@ -88,8 +100,24 @@
|
||||
(unless cond (error (format message ...))))))
|
||||
|
||||
(define/contract (make-audio-player cb-state cb-eof-stream
|
||||
#:use-place [use-place (place-enabled?)])
|
||||
(->* (procedure? procedure?) (#:use-place boolean?) audio-play?)
|
||||
#:use-place [use-place (place-enabled?)]
|
||||
#:remote-host [remote-host #f]
|
||||
#:remote-path-map [remote-path-map '()]
|
||||
#:remote-racket [remote-racket (current-racket-sound-remote-racket)]
|
||||
#:remote-module [remote-module (current-racket-sound-remote-module)]
|
||||
#:remote-command [remote-command #f]
|
||||
#:ssh-program [ssh-program (current-racket-sound-ssh-program)]
|
||||
#:ssh-options [ssh-options #f])
|
||||
(->* (procedure? procedure?)
|
||||
(#:use-place boolean?
|
||||
#:remote-host (or/c #f string?)
|
||||
#:remote-path-map remote-path-map?
|
||||
#:remote-racket path-string?
|
||||
#:remote-module string?
|
||||
#:remote-command (or/c #f (listof string?))
|
||||
#:ssh-program path-string?
|
||||
#:ssh-options (or/c #f (listof string?)))
|
||||
audio-play?)
|
||||
(let ((cmd-ch #f)
|
||||
(ret-ch #f)
|
||||
(evt-ch #f)
|
||||
@@ -101,38 +129,69 @@
|
||||
(rpc #f)
|
||||
(rpc-mutex (make-mutex))
|
||||
)
|
||||
(if use-place
|
||||
(begin
|
||||
(set! cmd-ch (dynamic-place placed-player-module 'placed-player))
|
||||
(set! cmd-put (λ (data) (place-channel-put cmd-ch data)))
|
||||
(set! au-pl cmd-ch)
|
||||
(set! dead-guard (λ () (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)))
|
||||
(place-channel-put cmd-ch (list 'init ret-ch-out evt-ch-out))
|
||||
(set! evt-ch evt-ch-in)
|
||||
(set! ret-ch ret-ch-in)
|
||||
(assert (is-return? (place-channel-get ret-ch-in) 'initialized)
|
||||
"Unexpected: not 'initialized returnd from 'init command"))
|
||||
)
|
||||
(begin
|
||||
(set! cmd-ch (make-async-channel))
|
||||
(set! cmd-put (λ (data) (async-channel-put cmd-ch data)))
|
||||
(set! au-pl (thread (λ () (placed-player cmd-ch))))
|
||||
(set! dead-guard (λ () (let ((evt (thread-dead-evt au-pl)))
|
||||
(sync evt))))
|
||||
(set! ret-ch (make-async-channel))
|
||||
(set! evt-ch (make-async-channel))
|
||||
(async-channel-put cmd-ch (list 'init ret-ch evt-ch))
|
||||
(assert (is-return? (async-channel-get ret-ch) 'initialized)
|
||||
"Unexpected: not 'initialized returnd from 'init command")
|
||||
)
|
||||
)
|
||||
(set! ret-get (λ () (to-ret-value (sync ret-ch))))
|
||||
(set! evt-get (λ (timeout-ms) (sync/timeout (/ timeout-ms 1000) evt-ch)))
|
||||
(set! rpc (λ (cmd . args) (with-mutex rpc-mutex
|
||||
(cmd-put (cons cmd args)) (ret-get))))
|
||||
(cond
|
||||
[remote-host
|
||||
;; Remote mode starts a worker over ssh. The remote worker uses
|
||||
;; placed-player/stdio, so the existing three logical channels map to
|
||||
;; ssh stdin, stdout and stderr. No init command is sent in this mode:
|
||||
;; the worker starts with all three channels already supplied.
|
||||
(let ((cmd (or remote-command (racket-sound-default-remote-command remote-racket remote-module))))
|
||||
(let-values (((cmd-ch* ret-ch* evt-ch* proc dead-guard*)
|
||||
(start-remote-placed-player remote-host
|
||||
#:ssh-program ssh-program
|
||||
#:ssh-options ssh-options
|
||||
#:remote-command cmd)))
|
||||
(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 (audio-remote-path (car args) remote-path-map) (cdr args))
|
||||
args))
|
||||
(cmd-put (cons cmd args*))
|
||||
(ret-get))))
|
||||
|
||||
(let* ((handle #f)
|
||||
(cb-state* (λ (st st-hash) (cb-state handle st st-hash)))
|
||||
@@ -142,7 +201,8 @@
|
||||
rpc
|
||||
au-pl
|
||||
#f
|
||||
(make-hash)))
|
||||
(make-hash)
|
||||
remote-path-map))
|
||||
(set-audio-play-evt-thread! handle
|
||||
(thread
|
||||
(λ ()
|
||||
|
||||
Reference in New Issue
Block a user