Implement connection methods

modules/ordo/connection.scm

@@ -1,32 +1,64 @@
 (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 (ssh session)
+  #:use-module (ssh channel)
   #:use-module (ssh auth)
   #:use-module (ssh popen)
-  #:use-module (srfi srfi-197))
+  #:use-module (srfi srfi-1) ;; list operations
+  #:use-module (srfi srfi-71) ;; extended let (multiple values)
+  #:use-module (srfi srfi-197) ;; chain
+  #:export (local-connection
+            ssh-connection
+            init!
+            close!
+            run
+            command-available?
+            read-binary-file
+            read-text-file
+            write-binary-file
+            write-text-file
+            copy-port))
 
 (define-class <connection> ()
   (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?))
 
 (define-class <local-connection> (<connection>))
 
+(define* (local-connection #:key (sudo? #f))
+  (make <local-connection> #:sudo? sudo?))
+
 (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!))
 
-(define-method (init! (c <local-connection>))
+(define* (ssh-connection user host #:key (sudo? #f))
-  c)
+  (make <ssh-connection> #:user user #:host host #:sudo? sudo?))
+
+(define-method (init! (c <local-connection>)) #t)
+
+(define-method (close! (c <local-connection>)) #t)
 
 (define-method (init! (c <ssh-connection>))
   (unless (slot-bound? c 'session)
-    (let ((session (make-session #:user (get-user c) #:host (get-host c))))
+    (set-session! c (make-session #:user (get-user c) #:host (get-host c))))
-      (connect! session)
+  (let ((s (get-session c)))
-      (userauth-public-key/auto! s)
+    (unless (connected? s)
-      (set-session! c session)))
+      (connect! s)
-  c)
+      (userauth-public-key/auto! s)))
+  #t)
+
+(define-method (close! (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?)
   (let ((cmd (list (if sudo? "sudo" "env"))))
@@ -36,6 +68,124 @@
                 (#t  (append _ (list prog)))
                 (args (append _ args)))))
 
-(define-method (run (c <local-connection>) pwd env prog args))
+(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 <ssh-connection>) pwd env prog args))
+(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)
+  (let* ((cmd (build-command pwd env prog args (sudo? c)))
+         (channel (apply 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 (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 (command-available? c command)
+  (let ((_ rc (run c "which" command)))
+    (zero? rc)))
+
+;; 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 (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))))))