From d16df7616f17ca6094ab9c23b8d3844dec6c2fc5 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 19 Jan 2025 12:18:20 +0000 Subject: [PATCH] Factor out connection types into different files --- modules/ordo/connection.scm | 204 +++++------------------------ modules/ordo/connection/base.scm | 23 ++++ modules/ordo/connection/local.scm | 20 +++ modules/ordo/connection/ssh.scm | 74 +++++++++++ modules/ordo/connection/sudo.scm | 60 +++++++++ modules/ordo/util/keyword-args.scm | 27 ++++ modules/ordo/util/read-lines.scm | 11 ++ 7 files changed, 251 insertions(+), 168 deletions(-) create mode 100644 modules/ordo/connection/base.scm create mode 100644 modules/ordo/connection/local.scm create mode 100644 modules/ordo/connection/ssh.scm create mode 100644 modules/ordo/connection/sudo.scm create mode 100644 modules/ordo/util/keyword-args.scm create mode 100644 modules/ordo/util/read-lines.scm diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index b6a5b0c..8dd40ce 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -1,194 +1,62 @@ (define-module (ordo connection) #:use-module (oop goops) #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (logging logger) #:use-module (srfi srfi-1) ; list operations - #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let - #: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 (ssh sftp) + #:use-module (ordo connection base) + #:use-module (ordo connection local) + #:use-module (ordo connection ssh) + #:use-module (ordo connection sudo) #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) - #:export ( - local-connection - ssh-connection - setup - teardown - connection-run - connection-call-with-input-file - connection-call-with-output-file + #:use-module (ordo util keyword-args) + #:export (connection call-with-connection run)) -(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-class ()) - -(define-class ()) - -(define-method (setup (c )) #f) - -(define-method (teardown (c )) #f) - -(define (local-connection) - (make )) - -(define-method (connection-run (c ) (command ) - (let* ((port (open-input-pipe command)) - (output (read-lines port)) - (exit-status (status:exit-val (close-pipe port)))) - (values output exit-status)))) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (call-with-input-file filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (call-with-output-file filename proc)) - -(define-class () - (user #:getter ssh-user #:init-keyword #:user) - (host #:getter ssh-host #:init-keyword #:host) - (password #:getter ssh-password #:init-keyword #:password) - (identity #:getter ssh-identity #:init-keyword #:identity) - (authenticate-server? #:getter ssh-authenticate-server? #:init-keyword authenticate-server?) - (session #:getter ssh-session #:setter set-ssh-session!) - (sftp-session #:getter sftp-session #:setter set-sftp-session!)) - -(define* (ssh-connection user host #:key (authenticate-server #t) password identity) - (make #:user user #:host host #:password password #:identity identity #:authenticate-server? authenticate-server)) - -(define-method (setup (c )) - (unless (slot-bound? c 'session) - (set-session! c (make-session #:user (ssh-user c) #:host (ssh-host c))) - (when (ssh-identity c) - (session-set! (ssh-session c) 'identity (ssh-identity c)))) - (let ((s (get-session c))) - (unless (connected? s) - (connect! s) - (when (authenticate-server? s) - (let ((server-auth (authenticate-server s))) - (unless (equal? 'ok server-auth) - (error (format #f "authenticate-server: ~a" server-auth))))) - (let ((user-auth (if (ssh-password c) - (userauth-password s (ssh-password c)) - (userauth-public-key/auto! s)))) - (unless (equal? 'success user-auth) - (error (format #f "userauth: ~a" user-auth))))))) - -(define-method (connection-run (c ) (command )) - (let* ((channel (open-remote-input-pipe (get-session c) command)) - (output (read-lines channel)) - (exit-status (channel-get-exit-status channel))) - (close channel) - (values output exit-status))) - -(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 (connection-call-with-input-file (c ) (filename ) (proc )) - (call-with-remote-input-file (sftp-session c) filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (call-with-remote-output-file (sftp-session c) filename proc)) - -(define-method (teardown (c )) - (when (slot-bound? c 'session) - (let ((s (get-session c))) - (when (connected? s) - (disconnect! s))))) - - -(define-class () - (parent-connection #:getter get-connection #:init-keyword #:connection) - (become-user #:getter get-become-user #:init-keyword #:become-user) - (become-password #:getter get-become-password #:init-keyworcd #:become-password) - (password-tmp-file #:getter get-password-tmp-file #:setter set-password-tmp-file!)) - -(define-method (setup (c )) - (setup (parent-connection c)) - (when (become-password c) - (let ((tmp-file (first (connection-run (parent-connection c) "mktemp")))) - (connection-call-with-output-file! (parent-connection c) tmp-file (cut write-line (become-password c) <>)) - (set-password-tmp-file! c tmp-file)))) - -(define-method (sudo-command (c )) - (cond - ((and (become-user c) (become-password c))) - (format #f "cat ~a - | sudo -k -S -H -u ~a" (shell-quote (get-password-tmp-file c)) (shell-quote (get-become-user c))) - - ((become-password c) - (format #f "cat ~a - | sudo -k -S -H" (shell-quote (get-password-tmp-file c)))) - - ((become-user c) - (format #f "sudo -k -n -H -u ~a" (shell-quote (get-become-user c)))) - - (else "sudo -k -n -H"))) - -(define-method (teardown (c )) - (when (slot-bound? c 'password-tmp-file) - (connection-run (parent-connection c) (format #f "rm -rf ~a" (shell-quote (get-password-tmp-file c))))) - (teardown (parent-connection c))) - -(define-method (connection-run (c ) (command )) - (let ((command (string-append (sudo-command c) " -- " command))) - (connection-run (parent-connection c) command))) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (connection-call-with-input-file (parent-connection c) filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (connection-call-with-output-file (parent-connection c) filename proc)) - -(define-method (build-command (c ) pwd env prog args) - (let ((cmd (chain-when (list (if (sudo? c) "sudo" "env")) - (pwd (append _ (list "--chdir" pwd))) - (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 _ " "))))) - (log-msg 'INFO "Running command: " cmd) - cmd)) - - +(define (connection type . kwargs) + (validate-keyword-args kwargs) + (let* ((c (case type + ((#:local) (make )) + ((#:ssh) (apply make + (select-keyword-args kwargs '(#:user #:host #:password #:identity #:authenticate-server?)))))) + (c (if (keyword-arg kwargs #:sudo?) + (apply make #:connection c (select-keyword-args kwargs '(#:become-user #:become-password))) + c))) + (conn:validate c) + c)) (define (call-with-connection c proc) (dynamic-wind - (lambda () (setup c)) + (lambda () (conn:setup c)) (lambda () (proc c)) - (lambda () (teardown c)))) + (lambda () (conn:teardown c)))) -(define* (keyword-arg kw args #:optional (default #f)) - (cond - ((< (length args) 2) default) - ((equal? (first args) kw) (second args)) - (else (keyword-arg kw (cddr args) default)))) +(define (build-command prog args pwd env) + (let ((xs (remove unspecified? + (flatten (list "env" + (when pwd (list "--chdir" (string-shell-quote pwd))) + (when env (map (match-lambda ((k . v) (string-append k "=" (string-shell-quote v)))) env)) + prog + (map string-shell-quote args) + "2>&1"))))) + (string-join xs " "))) (define (run conn prog . args) (let* ((args (flatten args)) (args kwargs (break keyword? args)) (args (remove unspecified? args)) - (pwd (keyword-arg #:pwd kwargs)) - (env (keyword-arg #:env kwargs)) - (return (keyword-arg #:return kwargs identity)) - (check? (keyword-arg #:check? kwargs #t)) - (out rc (connection-run conn pwd env prog args))) - (log-msg 'INFO "Command " prog " exited " rc) + (pwd (keyword-arg kwargs #:pwd)) + (env (keyword-arg kwargs #:env)) + (return (keyword-arg kwargs #:return identity)) + (check? (keyword-arg kwargs #:check?)) + (command (build-command prog args pwd env)) + (out rc (conn:run conn command))) + (log-msg 'INFO "Command " command " exited " rc) (if check? (if (zero? rc) (return out) diff --git a/modules/ordo/connection/base.scm b/modules/ordo/connection/base.scm new file mode 100644 index 0000000..3e67972 --- /dev/null +++ b/modules/ordo/connection/base.scm @@ -0,0 +1,23 @@ +(define-module (ordo connection base) + #:use-module (oop goops) + #:export ( + conn:validate + conn:setup + conn:teardown + conn:run + conn:call-with-input-file + conn:call-with-output-file)) + +(define-class ()) + +(define-method (conn:validate (c )) #t) + +(define-method (conn:setup (c )) #t) + +(define-method (conn:teardown (c )) #t) + +(define-generic conn:run) + +(define-generic conn:call-with-input-file) + +(define-generic conn:call-with-output-file) diff --git a/modules/ordo/connection/local.scm b/modules/ordo/connection/local.scm new file mode 100644 index 0000000..24c99d9 --- /dev/null +++ b/modules/ordo/connection/local.scm @@ -0,0 +1,20 @@ +(define-module (ordo connection local) + #:use-module (oop goops) + #:use-module (ice-9 popen) + #:use-module (ordo connection base) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class ()) + +(define-method (conn:run (c ) (command )) + (let* ((port (open-input-pipe command)) + (output (read-lines port)) + (exit-status (status:exit-val (close-pipe port)))) + (values output exit-status))) + +(define-method (conn:call-with-input-file (c ) (filename ) (proc )) + (call-with-input-file filename proc)) + +(define-method (conn:call-with-output-file (c ) (filename ) (proc )) + (call-with-output-file filename proc)) diff --git a/modules/ordo/connection/ssh.scm b/modules/ordo/connection/ssh.scm new file mode 100644 index 0000000..2b0015c --- /dev/null +++ b/modules/ordo/connection/ssh.scm @@ -0,0 +1,74 @@ +(define-module (ordo connection ssh) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 popen) + #:use-module (ssh session) + #:use-module (ssh channel) + #:use-module (ssh auth) + #:use-module (ssh popen) + #:use-module (ssh sftp) + #:use-module (ordo connection base) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class () + (user #:getter user #:init-keyword #:user) + (host #:getter host #:init-keyword #:host) + (password #:getter password #:init-keyword #:password #:init-val #f) + (identity #:getter identity #:init-keyword #:identity #:init-val #f) + (authenticate-server? #:getter authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t) + (session #:accessor session) + (sftp-session #:accessor sftp-session)) + +(define-method (conn:validate (c )) + (unless (slot-bound? c 'user) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "#:user is required")))) + (unless (slot-bound? c 'host) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "#:host is required"))))) + +(define-method (conn:setup (c )) + (unless (slot-bound? c 'session) + (set! (session c) (make-session #:user (user c) #:host (host c))) + (when (identity c) (session-set! (session c) 'identity (identity c)))) + (let ((s (session c))) + (unless (connected? s) + (connect! s) + (when (authenticate-server? s) + (let ((server-auth (authenticate-server s))) + (unless (equal? 'ok server-auth) + (error (format #f "authenticate-server: ~a" server-auth))))) + (let ((user-auth (if (password c) + (userauth-password! s (password c)) + (userauth-public-key/auto! s)))) + (unless (equal? 'success user-auth) + (error (format #f "userauth: ~a" user-auth))))))) + +(define-method (conn:run (c ) (command )) + (let* ((channel (open-remote-input-pipe (session c) command)) + (output (read-lines channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values output exit-status))) + +(define-method (sftp-session (c )) + (unless (slot-bound? c 'sftp-session) + (set! (sftp-session c) (make-sftp-session (session c)))) + (sftp-session c)) + +(define-method (conn:call-with-input-file (c ) (filename ) (proc )) + (call-with-remote-input-file (sftp-session c) filename proc)) + +(define-method (conn:call-with-output-file (c ) (filename ) (proc )) + (call-with-remote-output-file (sftp-session c) filename proc)) + +(define-method (conn:teardown (c )) + (when (slot-bound? c 'session) + (let ((s (session c))) + (when (connected? s) + (disconnect! s))))) diff --git a/modules/ordo/connection/sudo.scm b/modules/ordo/connection/sudo.scm new file mode 100644 index 0000000..95d47b2 --- /dev/null +++ b/modules/ordo/connection/sudo.scm @@ -0,0 +1,60 @@ +(define-module (ordo connection sudo) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ordo connection base) + #:use-module (ordo util shell-quote) + #:export ()) + +(define-class () + (connection #:getter connection #:init-keyword #:connection) + (become-user #:getter become-user #:init-keyword #:become-user #:init-form #f) + (become-password #:getter become-password #:init-keyword #:become-password #:init-form #f) + (password-tmp-file #:accessor password-tmp-file)) + +(define-method (conn:validate (c )) + (conn:validate (connection c))) + +(define-method (conn:setup (c )) + (conn:setup (connection c)) + (when (become-password c) + (let ((out rc (conn:run (connection c) "mktemp"))) + (unless (zero? rc) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out)))))) + (let ((tmp-file (car out))) + (conn:call-with-output-file (connection c) tmp-file (cut write-line (become-password c) <>)) + (set! (password-tmp-file c) tmp-file))))) + +(define-method (sudo-command (c )) + (cond + ((and (become-user c) (become-password c)) + (format #f "cat ~a - | sudo -k -S -H -u ~a" (string-shell-quote (password-tmp-file c)) (string-shell-quote (become-user c)))) + + ((become-password c) + (format #f "cat ~a - | sudo -k -S -H" (string-shell-quote (password-tmp-file c)))) + + ((become-user c) + (format #f "sudo -k -n -H -u ~a" (string-shell-quote (become-user c)))) + + (else "sudo -k -n -H"))) + +(define-method (conn:teardown (c )) + (when (slot-bound? c 'password-tmp-file) + (conn:run (connection c) (format #f "rm -f ~a" (string-shell-quote (password-tmp-file c))))) + (conn:teardown (connection c))) + +(define-method (conn:run (c ) (command )) + (let ((command (string-append (sudo-command c) " -- " command))) + (conn:run (connection c) command))) + +;; There is no special sudo handling for file I/O. This means the caller needs to +;; ensure that they have read/write access to the target file. +(define-method (conn:call-with-input-file (c ) (filename ) (proc )) + (conn:call-with-input-file (connection c) filename proc)) + +(define-method (conn:call-with-output-file (c ) (filename ) (proc )) + (conn:call-with-output-file (connection c) filename proc)) diff --git a/modules/ordo/util/keyword-args.scm b/modules/ordo/util/keyword-args.scm new file mode 100644 index 0000000..76441c1 --- /dev/null +++ b/modules/ordo/util/keyword-args.scm @@ -0,0 +1,27 @@ +(define-module (ordo util keyword-args) + #:use-module (ice-9 exceptions) + #:export (keyword-arg + select-keyword-args + validate-keyword-args)) + +(define* (keyword-arg args kw #:optional (default #f)) + (cond + ((< (length args) 2) default) + ((equal? (car args) kw) (cadr args)) + (else (keyword-arg (cddr args) kw default)))) + +(define (select-keyword-args kwargs wanted) + (let loop ((kwargs kwargs) (accum '())) + (cond + ((null? kwargs) + (reverse accum)) + ((member (car kwargs) wanted) + (loop (cddr kwargs) (cons* (car kwargs) (cadr kwargs) accum))) + (else (loop (cddr kwargs) accum))))) + +(define (validate-keyword-args kwargs) + (unless (even? (length kwargs)) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "keyword args should have an even number of elements"))))) diff --git a/modules/ordo/util/read-lines.scm b/modules/ordo/util/read-lines.scm new file mode 100644 index 0000000..def581d --- /dev/null +++ b/modules/ordo/util/read-lines.scm @@ -0,0 +1,11 @@ +(define-module (ordo util read-lines) + #:use-module (ice-9 rdelim) + #:export (read-lines)) + +(define (read-lines port) + "Read lines from port until eof is encountered. Return list of all lines read." + (define (loop line result) + (if (eof-object? line) + (reverse result) + (loop (read-line port) (cons line result)))) + (loop (read-line port) '()))