Rework connection handling
* Capture stderr from run * Simplify remote file handling
This commit is contained in:
parent
428c6ed4a5
commit
d5593f4e3d
GPG key ID:
043F786C4CD681B8
2 changed files with 73 additions and 142 deletions
|
|
@ -1,191 +1,122 @@
|
|||
(define-module (ordo connection)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 string-fun)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (srfi srfi-1) ; list operations
|
||||
#:use-module ((srfi srfi-197) #:select (chain-when))
|
||||
#:use-module (ssh session)
|
||||
#:use-module (ssh channel)
|
||||
#:use-module (ssh auth)
|
||||
#:use-module (ssh popen)
|
||||
#:use-module (srfi srfi-1) ;; list operations
|
||||
#:use-module (srfi srfi-71) ;; extended let (multiple values)
|
||||
#:use-module (srfi srfi-197) ;; chain
|
||||
#:use-module (ssh sftp)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:export (local-connection
|
||||
ssh-connection
|
||||
init!
|
||||
close!
|
||||
run
|
||||
command-available?
|
||||
read-binary-file
|
||||
read-text-file
|
||||
write-binary-file
|
||||
write-text-file
|
||||
copy-port))
|
||||
init-connection!
|
||||
close-connection!
|
||||
connection-run
|
||||
connection-call-with-input-file
|
||||
connection-call-with-output-file
|
||||
call-with-connection))
|
||||
|
||||
(define-class <connection> ()
|
||||
(sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?))
|
||||
(define-class <connection> ())
|
||||
|
||||
(define-class <local-connection> (<connection>))
|
||||
|
||||
(define* (local-connection #:key (sudo? #f))
|
||||
(make <local-connection> #:sudo? sudo?))
|
||||
(define (local-connection)
|
||||
(make <local-connection>))
|
||||
|
||||
(define-class <ssh-connection> (<connection>)
|
||||
(user #:getter get-user #:init-keyword #:user)
|
||||
(host #:getter get-host #:init-keyword #:host)
|
||||
(session #:getter get-session #:setter set-session!))
|
||||
(session #:getter get-session #:setter set-session!)
|
||||
(sftp-session #:getter get-sftp-session #:setter set-sftp-session!))
|
||||
|
||||
(define* (ssh-connection user host #:key (sudo? #f))
|
||||
(make <ssh-connection> #:user user #:host host #:sudo? sudo?))
|
||||
(define (ssh-connection user host)
|
||||
(make <ssh-connection> #:user user #:host host))
|
||||
|
||||
(define-method (init! (c <local-connection>)) #t)
|
||||
(define-method (init-connection! (c <connection>)) #f)
|
||||
|
||||
(define-method (close! (c <local-connection>)) #t)
|
||||
(define-method (close-connection! (c <connection>)) #f)
|
||||
|
||||
(define-method (init! (c <ssh-connection>))
|
||||
(define-method (init-connection! (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'session)
|
||||
(set-session! c (make-session #:user (get-user c) #:host (get-host c))))
|
||||
(let ((s (get-session c)))
|
||||
(unless (connected? s)
|
||||
(connect! s)
|
||||
(userauth-public-key/auto! s)))
|
||||
(let ((server-auth (authenticate-server s)))
|
||||
(unless (equal? 'ok server-auth)
|
||||
(error (format #f "authenticate-server: ~a" server-auth))))
|
||||
(let ((user-auth (userauth-public-key/auto! s)))
|
||||
(unless (equal? 'success user-auth)
|
||||
(error (format #f "userauth-public-key: ~a" user-auth))))))
|
||||
#t)
|
||||
|
||||
(define-method (close! (c <ssh-connection>))
|
||||
(define-method (sftp-session (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'sftp-session)
|
||||
(set-sftp-session! c (make-sftp-session (get-session c))))
|
||||
(get-sftp-session c))
|
||||
|
||||
(define-method (close-connection! (c <ssh-connection>))
|
||||
(when (slot-bound? c 'session)
|
||||
(let ((s (get-session c)))
|
||||
(when (connected? s)
|
||||
(disconnect! s)))))
|
||||
|
||||
(define (build-command pwd env prog args sudo?)
|
||||
(define (read-lines port)
|
||||
(define (loop line result)
|
||||
(if (eof-object? line)
|
||||
(reverse result)
|
||||
(loop (read-line port) (cons line result))))
|
||||
(loop (read-line port) '()))
|
||||
|
||||
(define (kw-arg kw kwargs)
|
||||
(cond
|
||||
((null? (kwargs)) #f)
|
||||
((equal? (car kwargs) kw) (cadr kwargs))
|
||||
(else (kw-arg kw (cddr kwargs)))))
|
||||
|
||||
(define (build-command pwd env sudo? prog args)
|
||||
(let ((cmd (list (if sudo? "sudo" "env"))))
|
||||
(chain-when cmd
|
||||
(pwd (append _ (list "--chdir" pwd)))
|
||||
(env (append _ (map (lambda (x) (format #f "~a=~a" (car x) (cdr x))) env)))
|
||||
(#t (append _ (list prog)))
|
||||
(args (append _ args)))))
|
||||
(env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env)))
|
||||
(#t (append _
|
||||
(list prog)
|
||||
(map string-shell-quote args)
|
||||
(list "2>&1")))
|
||||
(#t (string-join _ " ")))))
|
||||
|
||||
(define (read-lines port)
|
||||
(define (loop line result)
|
||||
(if (eof-object? line) (reverse result) (loop (read-line port) (cons line result))))
|
||||
(loop (read-line port) '()))
|
||||
|
||||
(define-method (%run (c <local-connection>) pwd env prog args)
|
||||
(let* ((cmd (build-command pwd env prog args (sudo? c)))
|
||||
(port (apply open-pipe* OPEN_READ cmd))
|
||||
(define-method (connection-run (c <local-connection>) pwd env sudo? prog args)
|
||||
(let* ((cmd (build-command pwd env sudo? prog args))
|
||||
(port (open-input-pipe cmd))
|
||||
(output (read-lines port))
|
||||
(exit-status (status:exit-val (close-pipe port))))
|
||||
(values output exit-status)))
|
||||
|
||||
(define-method (%run (c <ssh-connection>) pwd env prog args)
|
||||
(let* ((cmd (build-command pwd env prog args (sudo? c)))
|
||||
(channel (apply open-remote-input-pipe* (get-session c) cmd))
|
||||
(define-method (connection-run (c <ssh-connection>) pwd env sudo? prog args)
|
||||
(let* ((cmd (build-command pwd env sudo? prog args))
|
||||
(channel (open-remote-input-pipe (get-session c) cmd))
|
||||
(output (read-lines channel))
|
||||
(exit-status (channel-get-exit-status channel)))
|
||||
(close channel)
|
||||
(values output exit-status)))
|
||||
|
||||
(define (find-kw-arg kw kwargs)
|
||||
(let loop ((kwargs kwargs))
|
||||
(cond
|
||||
((null? kwargs) #f)
|
||||
((equal? (car kwargs) kw) (cadr kwargs))
|
||||
(else (loop (cddr kwargs))))))
|
||||
(define-method (connection-call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-input-file filename proc))
|
||||
|
||||
(define (run c prog . rest)
|
||||
(let ((args (take-while (negate keyword?) rest))
|
||||
(kwargs (drop-while (negate keyword?) rest)))
|
||||
(unless (even? (length kwargs))
|
||||
(error "keyword arguments require a value"))
|
||||
(let ((pwd (find-kw-arg #:pwd kwargs))
|
||||
(env (find-kw-arg #:env kwargs)))
|
||||
(%run c pwd env prog args))))
|
||||
(define-method (connection-call-with-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-input-file (sftp-session c) filename proc))
|
||||
|
||||
(define (command-available? c command)
|
||||
(let ((_ rc (run c "which" command)))
|
||||
(zero? rc)))
|
||||
(define-method (connection-call-with-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-output-file filename proc))
|
||||
|
||||
;; These functions for reading and writing files are using cat (with output
|
||||
;; redirection for writing) rather than opening the files directly so that the
|
||||
;; command can be invoked under sudo when necessary.
|
||||
(define-method (connection-call-with-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-output-file (sftp-session c) filename proc))
|
||||
|
||||
(define-method (read-file (c <local-connection>) (path <string>) (reader <procedure>))
|
||||
(let* ((cmd (build-command #f #f "cat" (list path) (sudo? c)))
|
||||
(port (apply open-pipe* OPEN_READ cmd))
|
||||
(output (reader port))
|
||||
(exit-status (status:exit-val (close-pipe port))))
|
||||
(unless (zero? exit-status)
|
||||
(error (format #f "error reading local text file ~a" path)))
|
||||
output))
|
||||
|
||||
(define-method (read-file (c <ssh-connection>) (path <string>) (reader <procedure>))
|
||||
(let* ((cmd (build-command #f #f "cat" (list path) (sudo? c)))
|
||||
(channel (apply open-remote-input-pipe* (get-session c) cmd))
|
||||
(output (reader channel))
|
||||
(exit-status (channel-get-exit-status channel)))
|
||||
(close channel)
|
||||
(unless (zero? exit-status)
|
||||
(error (format #f "error reading text file ~a@~a:~a" (get-user c) (get-host c) path)))
|
||||
output))
|
||||
|
||||
(define (read-text-file c path)
|
||||
(read-file c path get-string-all))
|
||||
|
||||
(define (read-binary-file c path)
|
||||
(read-file c path get-bytevector-all))
|
||||
|
||||
(define (shell-quote s)
|
||||
"Quote string S for sh-compatible shells."
|
||||
(string-append "'" (string-replace-substring s "'" "'\\''") "'"))
|
||||
|
||||
;; These methods for writing files require the file content to be read into memory. They
|
||||
;; are useful for small files, but prefer COPY-FILE for larger ones.
|
||||
|
||||
(define-method (write-file (c <local-connection>) (path <string>) (writer <procedure>) content)
|
||||
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c)))
|
||||
(port (apply open-pipe* OPEN_WRITE cmd)))
|
||||
(writer port content)
|
||||
(unless (zero? (status:exit-val (close-pipe port)))
|
||||
(error (format #f "error writing local text file ~a" path)))))
|
||||
|
||||
(define-method (write-file (c <ssh-connection>) (path <string>) (writer <procedure>) content)
|
||||
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c)))
|
||||
(channel (apply open-remote-output-pipe* (get-session c) cmd)))
|
||||
(writer channel content)
|
||||
(channel-send-eof channel)
|
||||
(let ((exit-status (channel-get-exit-status channel)))
|
||||
(close channel)
|
||||
(unless (zero? exit-status)
|
||||
(error (format #f "error writing text file ~a@~a:~a" (get-user c) (get-host c) path))))))
|
||||
|
||||
(define (write-text-file c path content)
|
||||
(write-file c path put-string content))
|
||||
|
||||
(define (write-binary-file c path content)
|
||||
(write-file c path put-bytevector content))
|
||||
|
||||
(define-method (copy-port (c <local-connection>) (src <port>) (dest-path <string>))
|
||||
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c)))
|
||||
(dport (apply open-pipe* OPEN_WRITE cmd)))
|
||||
(let loop ((data (get-bytevector-some src)))
|
||||
(unless (eof-object? data)
|
||||
(put-bytevector dport data)
|
||||
(loop (get-bytevector-some src))))
|
||||
(unless (zero? (status:exit-val (close-pipe dport)))
|
||||
(error (format #f "error copying file to ~a" dest-path)))))
|
||||
|
||||
(define-method (copy-port (c <ssh-connection>) (src <port>) (dest-path <string>))
|
||||
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c)))
|
||||
(channel (apply open-remote-output-pipe* (get-session c) cmd)))
|
||||
(let loop ((data (get-bytevector-some src)))
|
||||
(unless (eof-object? data)
|
||||
(put-bytevector channel data)
|
||||
(loop (get-bytevector-some src))))
|
||||
(channel-send-eof channel)
|
||||
(let ((exit-status (channel-get-exit-status channel)))
|
||||
(close channel)
|
||||
(unless (zero? exit-status)
|
||||
(error (format #f "error copying file to ~a@~a:~a" (get-user c) (get-host c) dest-path))))))
|
||||
(define (call-with-connection c proc)
|
||||
(dynamic-wind
|
||||
(lambda () (init-connection! c))
|
||||
(lambda () (proc c))
|
||||
(lambda () (close-connection! c))))
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
(define-module (ordo util shell-quote)
|
||||
#:use-module (rx irregex)
|
||||
#:use-module ((srfi srfi-197) #:select (chain))
|
||||
#:export (shell-quote-string))
|
||||
#:export (string-shell-quote))
|
||||
|
||||
(define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^")))))
|
||||
|
||||
|
|
@ -49,7 +49,7 @@
|
|||
(irregex-replace (irregex '(seq bos "''")) _ "")
|
||||
(irregex-replace (irregex '(seq "''" eos)) _ "")))
|
||||
|
||||
(define (shell-quote-string s)
|
||||
(define (string-shell-quote s)
|
||||
"Quote strings for passing through the shell"
|
||||
(cond
|
||||
((zero? (string-length s)) "''")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue