#lang racket/base

(require racket/list
         racket/path
         racket/string
         racket/system
         port-channel
         uni-channel)

(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
         start-remote-placed-player)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Remote path mapping
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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 (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))])]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSH / subprocess defaults
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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 (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)])
  (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 (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 (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-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))
  (define dead-guard (lambda () (subprocess-wait proc)))
  (values cmd-ch ret-ch evt-ch proc dead-guard))