From d7b49f2b3bf7a0a05639c36747cff4f7cd777757 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 3 Jan 2025 17:46:21 +0000 Subject: [PATCH] Implement connection methods --- modules/ordo/connection.scm | 170 +++++++++++++++++++++++++++++++++--- 1 file changed, 160 insertions(+), 10 deletions(-) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 7812419..c4b48ae 100644 --- a/modules/ordo/connection.scm +++ b/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 () (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?)) (define-class ()) +(define* (local-connection #:key (sudo? #f)) + (make #:sudo? sudo?)) + (define-class () (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 )) - c) +(define* (ssh-connection user host #:key (sudo? #f)) + (make #:user user #:host host #:sudo? sudo?)) + +(define-method (init! (c )) #t) + +(define-method (close! (c )) #t) (define-method (init! (c )) (unless (slot-bound? c 'session) - (let ((session (make-session #:user (get-user c) #:host (get-host c)))) - (connect! session) - (userauth-public-key/auto! s) - (set-session! c session))) - c) + (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))) + #t) + +(define-method (close! (c )) + (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 ) 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 ) pwd env prog args)) +(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)) + (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)) + (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 ) (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))))))