Rework connection handling

* Capture stderr from run
* Simplify remote file handling

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 (srfi srfi-1) ; list operations
-  #:use-module (ice-9 binary-ports)
+  #:use-module ((srfi srfi-197) #:select (chain-when))
-  #:use-module (ice-9 textual-ports)
   #: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 (ssh sftp)
-  #:use-module (srfi srfi-71) ;; extended let (multiple values)
+  #:use-module (ordo util shell-quote)
-  #:use-module (srfi srfi-197) ;; chain
   #:export (local-connection
             ssh-connection
-            init!
+            init-connection!
-            close!
+            close-connection!
-            run
+            connection-run
-            command-available?
+            connection-call-with-input-file
-            read-binary-file
+            connection-call-with-output-file
-            read-text-file
+            call-with-connection))
-            write-binary-file
-            write-text-file
-            copy-port))
 
-(define-class <connection> ()
+(define-class <connection> ())
-  (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?))
 
 (define-class <local-connection> (<connection>))
 
-(define* (local-connection #:key (sudo? #f))
+(define (local-connection)
-  (make <local-connection> #:sudo? sudo?))
+  (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))
+(define (ssh-connection user host)
-  (make <ssh-connection> #:user user #:host host #:sudo? sudo?))
+  (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)))
+                (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env)))
-                (#t  (append _ (list prog)))
+                (#t (append _
-                (args (append _ args)))))
+                            (list prog)
+                            (map string-shell-quote args)
+                            (list "2>&1")))
+                (#t (string-join _ " ")))))
 
-(define (read-lines port)
+(define-method (connection-run (c <local-connection>) pwd env sudo? prog args)
-  (define (loop line result)
+  (let* ((cmd (build-command pwd env sudo? prog args))
-    (if (eof-object? line) (reverse result) (loop (read-line port) (cons line result))))
+         (port (open-input-pipe cmd))
-  (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))
          (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)
+(define-method (connection-run (c <ssh-connection>) pwd env sudo? prog args)
-  (let* ((cmd (build-command pwd env prog args (sudo? c)))
+  (let* ((cmd (build-command pwd env sudo? prog args))
-         (channel (apply open-remote-input-pipe* (get-session c) cmd))
+         (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)
+(define-method (connection-call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
-  (let loop ((kwargs kwargs))
+  (call-with-input-file filename proc))
-    (cond
-     ((null? kwargs) #f)
-     ((equal? (car kwargs) kw) (cadr kwargs))
-     (else (loop (cddr kwargs))))))
 
-(define (run c prog . rest)
+(define-method (connection-call-with-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
-  (let ((args (take-while (negate keyword?) rest))
+  (call-with-remote-input-file (sftp-session c) filename proc))
-        (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 (command-available? c command)
+(define-method (connection-call-with-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
-  (let ((_ rc (run c "which" command)))
+  (call-with-output-file filename proc))
-    (zero? rc)))
 
-;; These functions for reading and writing files are using cat (with output
+(define-method (connection-call-with-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
-;; redirection for writing) rather than opening the files directly so that the
+  (call-with-remote-output-file (sftp-session c) filename proc))
-;; command can be invoked under sudo when necessary.
 
-(define-method (read-file (c <local-connection>) (path <string>) (reader <procedure>))
+(define (call-with-connection c proc)
-  (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c)))
+  (dynamic-wind
-         (port (apply open-pipe* OPEN_READ cmd))
+    (lambda () (init-connection! c))
-         (output (reader port))
+    (lambda () (proc c))
-         (exit-status (status:exit-val (close-pipe port))))
+    (lambda () (close-connection! c))))
-    (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))))))

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)) "''")