diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index c4b48ae..11c8295 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -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 () - (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?)) +(define-class ()) (define-class ()) -(define* (local-connection #:key (sudo? #f)) - (make #:sudo? sudo?)) +(define (local-connection) + (make )) (define-class () (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 #:user user #:host host #:sudo? sudo?)) +(define (ssh-connection user host) + (make #:user user #:host host)) -(define-method (init! (c )) #t) +(define-method (init-connection! (c )) #f) -(define-method (close! (c )) #t) +(define-method (close-connection! (c )) #f) -(define-method (init! (c )) +(define-method (init-connection! (c )) (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 )) +(define-method (sftp-session (c )) + (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 )) (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 ) 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 ) 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 ) 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 ) 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 ) (filename ) (proc )) + (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 ) (filename ) (proc )) + (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 ) (filename ) (proc )) + (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 ) (filename ) (proc )) + (call-with-remote-output-file (sftp-session c) filename proc)) -(define-method (read-file (c ) (path ) (reader )) - (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 ) (path ) (reader )) - (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 ) (path ) (writer ) 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 ) (path ) (writer ) 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 ) (src ) (dest-path )) - (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 ) (src ) (dest-path )) - (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)))) diff --git a/modules/ordo/util/shell-quote.scm b/modules/ordo/util/shell-quote.scm index 84268e7..5de60fa 100644 --- a/modules/ordo/util/shell-quote.scm +++ b/modules/ordo/util/shell-quote.scm @@ -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)) "''")