110 lines
3.7 KiB
Racket
110 lines
3.7 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/path
|
|
racket/string
|
|
port-channel
|
|
uni-channel
|
|
"config.rkt"
|
|
"utils.rkt"
|
|
)
|
|
|
|
(provide replace-base-paths?
|
|
replace-base-path
|
|
start-remote-placed-player)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Remote path replacement
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (path-string->string p)
|
|
(if (path? p) (path->string p) p))
|
|
|
|
(define (replace-base-paths? v)
|
|
(and (list? v)
|
|
(andmap (lambda (entry)
|
|
(and (pair? entry)
|
|
(path-string? (car entry))
|
|
(path-string? (cdr entry))))
|
|
v)))
|
|
|
|
(define (get-path-separator s)
|
|
(let ((m (regexp-match #rx"[\\\\/]" s)))
|
|
(if (eq? m #f)
|
|
(begin
|
|
(warn-sound "No delimiter found in ~a, assuming unix: '/'" s)
|
|
"/")
|
|
(car m))))
|
|
|
|
(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)
|
|
(let* ((new-path* (string-append base-path-remote
|
|
(substring s (string-length base-path-local))))
|
|
(delim (get-path-separator new-path*))
|
|
(new-path (string-replace (string-replace new-path* "/" delim) "\\" delim))
|
|
)
|
|
new-path
|
|
)
|
|
(loop (cdr entries))))]))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Remote placed player
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (executable-name p)
|
|
(let ((p* (if (path? p) p (string->path p))))
|
|
(path->string (file-name-from-path p*))))
|
|
|
|
(define (plink-program? p)
|
|
(regexp-match? #rx"(?i:^plink(\\.exe)?$)" (executable-name p)))
|
|
|
|
(define (ssh-options ssh-program)
|
|
(if (plink-program? ssh-program)
|
|
'("-batch" "-T" "-load")
|
|
'("-T" "-q")))
|
|
|
|
(define (shell-quote s)
|
|
(string-append "'"
|
|
(regexp-replace* #rx"'" s "'\"'\"'")
|
|
"'"))
|
|
|
|
(define (remote-command remote-host #:cmd [cmd #f])
|
|
(if (eq? cmd #f)
|
|
(list (audio-remote-cfg-get remote-host 'remote-racket)
|
|
"-l"
|
|
(audio-remote-cfg-get remote-host 'remote-module)
|
|
"--"
|
|
"--stdio")
|
|
(list (audio-remote-cfg-get remote-host 'remote-racket)
|
|
"-e"
|
|
(shell-quote cmd)
|
|
"--"
|
|
"--stdio")
|
|
)
|
|
)
|
|
|
|
(define (start-ssh-subprocess remote-host #:cmd [cmd #f])
|
|
(let* ((ssh-program (audio-cfg-get 'ssh-program))
|
|
(args (append (ssh-options ssh-program)
|
|
(list remote-host)
|
|
(remote-command remote-host #:cmd cmd))))
|
|
(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 (start-remote-placed-player remote-host)
|
|
(define-values (proc 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))
|