Remote audio player much simpler.
This commit is contained in:
+44
-116
@@ -1,80 +1,45 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/path
|
||||
(require racket/path
|
||||
racket/string
|
||||
racket/system
|
||||
port-channel
|
||||
uni-channel)
|
||||
uni-channel
|
||||
"config.rkt")
|
||||
|
||||
(provide remote-path-map?
|
||||
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
|
||||
racket-sound-resolve-executable
|
||||
racket-sound-start-ssh-subprocess
|
||||
current-racket-sound-ssh-program
|
||||
current-racket-sound-remote-racket
|
||||
current-racket-sound-remote-module
|
||||
make-remote-port-uni-channels
|
||||
(provide replace-base-paths?
|
||||
replace-base-path
|
||||
start-remote-placed-player)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Remote path mapping
|
||||
;; Remote path replacement
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (path-string->string p)
|
||||
(if (path? p) (path->string p) p))
|
||||
|
||||
(define (remote-path-map? v)
|
||||
(or (not v)
|
||||
(procedure? v)
|
||||
(and (list? v)
|
||||
(andmap (lambda (entry)
|
||||
(cond [(and (pair? entry) (pair? (cdr entry)) (null? (cddr entry)))
|
||||
(and (path-string? (car entry)) (path-string? (cadr entry)))]
|
||||
[(and (pair? entry) (path-string? (car entry)) (path-string? (cdr entry))) #t]
|
||||
[(vector? entry)
|
||||
(and (= (vector-length entry) 2)
|
||||
(path-string? (vector-ref entry 0))
|
||||
(path-string? (vector-ref entry 1)))]
|
||||
[else #f]))
|
||||
v))))
|
||||
(define (replace-base-paths? v)
|
||||
(and (list? v)
|
||||
(andmap (lambda (entry)
|
||||
(and (pair? entry)
|
||||
(path-string? (car entry))
|
||||
(path-string? (cdr entry))))
|
||||
v)))
|
||||
|
||||
(define (path-map-entry-local entry)
|
||||
(path-string->string
|
||||
(cond [(vector? entry) (vector-ref entry 0)]
|
||||
[(and (pair? entry) (pair? (cdr entry)) (null? (cddr entry))) (car entry)]
|
||||
[else (car entry)])))
|
||||
|
||||
(define (path-map-entry-remote entry)
|
||||
(path-string->string
|
||||
(cond [(vector? entry) (vector-ref entry 1)]
|
||||
[(and (pair? entry) (pair? (cdr entry)) (null? (cddr entry))) (cadr entry)]
|
||||
[else (cdr entry)])))
|
||||
|
||||
(define (replace-prefix s from to)
|
||||
(string-append to (substring s (string-length from))))
|
||||
|
||||
(define (audio-remote-path path map)
|
||||
(define s (path-string->string path))
|
||||
(cond [(not map) s]
|
||||
[(procedure? map) (map s)]
|
||||
[(null? map) s]
|
||||
[else
|
||||
(define matches
|
||||
(filter (lambda (entry) (string-prefix? s (path-map-entry-local entry))) map))
|
||||
(cond [(null? matches) s]
|
||||
[else
|
||||
(define best
|
||||
(argmax (lambda (entry) (string-length (path-map-entry-local entry))) matches))
|
||||
(replace-prefix s (path-map-entry-local best) (path-map-entry-remote best))])]))
|
||||
(define (replace-base-path path replace-base-paths)
|
||||
(let ((s (path-string->string path)))
|
||||
(let loop ((entries replace-base-paths))
|
||||
(cond [(null? entries) s]
|
||||
[else
|
||||
(let* ((entry (car entries))
|
||||
(base-path-local (path-string->string (car entry)))
|
||||
(base-path-remote (path-string->string (cdr entry))))
|
||||
(if (string-prefix? s base-path-local)
|
||||
(string-append base-path-remote
|
||||
(substring s (string-length base-path-local)))
|
||||
(loop (cdr entries))))]))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SSH / subprocess defaults
|
||||
;; Remote placed player
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (executable-name p)
|
||||
@@ -84,70 +49,33 @@
|
||||
(define (plink-program? p)
|
||||
(regexp-match? #rx"(?i:^plink(\\.exe)?$)" (executable-name p)))
|
||||
|
||||
(define (racket-sound-default-ssh-program)
|
||||
(cond [(eq? (system-type 'os) 'windows)
|
||||
(cond [(find-executable-path "plink.exe") => values]
|
||||
[(find-executable-path "plink") => values]
|
||||
[(find-executable-path "ssh.exe") => values]
|
||||
[(find-executable-path "ssh") => values]
|
||||
[else "plink.exe"])]
|
||||
[else
|
||||
(cond [(find-executable-path "ssh") => values]
|
||||
[else "ssh"])]))
|
||||
|
||||
(define (racket-sound-default-ssh-options [ssh-program (racket-sound-default-ssh-program)])
|
||||
(define (ssh-options ssh-program)
|
||||
(if (plink-program? ssh-program)
|
||||
'("-batch" "-T")
|
||||
'("-T" "-q")))
|
||||
|
||||
(define (racket-sound-default-remote-racket) "racket")
|
||||
(define (racket-sound-default-remote-module) "racket-audio/audio-placed-player")
|
||||
(define (remote-command remote-host)
|
||||
(list (audio-remote-cfg-get remote-host 'remote-racket)
|
||||
"-l"
|
||||
(audio-remote-cfg-get remote-host 'remote-module)
|
||||
"--"
|
||||
"--stdio"))
|
||||
|
||||
(define (racket-sound-default-remote-command
|
||||
[remote-racket (racket-sound-default-remote-racket)]
|
||||
[remote-module (racket-sound-default-remote-module)])
|
||||
(list remote-racket "-l" remote-module "--" "--stdio"))
|
||||
|
||||
(define current-racket-sound-ssh-program
|
||||
(make-parameter (racket-sound-default-ssh-program)))
|
||||
|
||||
(define current-racket-sound-remote-racket
|
||||
(make-parameter (racket-sound-default-remote-racket)))
|
||||
|
||||
(define current-racket-sound-remote-module
|
||||
(make-parameter (racket-sound-default-remote-module)))
|
||||
|
||||
(define (racket-sound-resolve-executable p)
|
||||
(or (find-executable-path p) p))
|
||||
|
||||
(define (racket-sound-start-ssh-subprocess remote-host remote-command
|
||||
#:ssh-program [ssh-program (current-racket-sound-ssh-program)]
|
||||
#:ssh-options [ssh-options #f])
|
||||
(define ssh-options* (or ssh-options (racket-sound-default-ssh-options ssh-program)))
|
||||
(define args (append ssh-options* (list remote-host) remote-command))
|
||||
(apply subprocess #f #f #f (racket-sound-resolve-executable ssh-program) args))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Port-channel wrapping
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (start-ssh-subprocess remote-host)
|
||||
(let* ((ssh-program (audio-cfg-get 'ssh-program))
|
||||
(args (append (ssh-options ssh-program)
|
||||
(list remote-host)
|
||||
(remote-command remote-host))))
|
||||
(apply subprocess #f #f #f ssh-program args)))
|
||||
|
||||
(define (make-port-uc port direction source)
|
||||
(make-uni-channel (make-port-channel port #:direction direction #:source source #:close? #t)))
|
||||
|
||||
(define (make-remote-port-uni-channels stdout stdin stderr)
|
||||
(values (make-port-uc stdin 'output 'remote-stdin)
|
||||
(make-port-uc stdout 'input 'remote-stdout)
|
||||
(make-port-uc stderr 'input 'remote-stderr)))
|
||||
|
||||
(define (start-remote-placed-player remote-host
|
||||
#:ssh-program [ssh-program (current-racket-sound-ssh-program)]
|
||||
#:ssh-options [ssh-options #f]
|
||||
#:remote-command [remote-command (racket-sound-default-remote-command)])
|
||||
(define (start-remote-placed-player remote-host)
|
||||
(define-values (proc stdout stdin stderr)
|
||||
(racket-sound-start-ssh-subprocess remote-host remote-command
|
||||
#:ssh-program ssh-program
|
||||
#:ssh-options ssh-options))
|
||||
(define-values (cmd-ch ret-ch evt-ch)
|
||||
(make-remote-port-uni-channels stdout stdin stderr))
|
||||
(start-ssh-subprocess remote-host))
|
||||
(define cmd-ch (make-port-uc stdin 'output 'remote-stdin))
|
||||
(define ret-ch (make-port-uc stdout 'input 'remote-stdout))
|
||||
(define evt-ch (make-port-uc stderr 'input 'remote-stderr))
|
||||
(define dead-guard (lambda () (subprocess-wait proc)))
|
||||
(values cmd-ch ret-ch evt-ch proc dead-guard))
|
||||
|
||||
Reference in New Issue
Block a user