From f6ef09f91db6d72404936940f061bd4b5766595d Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 31 May 2025 16:50:06 +0100 Subject: [PATCH] Get rudimentary connections working again --- ordo/connection.scm | 59 +++++++++++++++++++++++++++++++++++ ordo/connection/base.scm | 40 ++++++++++++++++++++++++ ordo/connection/local.scm | 21 +++++++++++++ ordo/connection/ssh.scm | 63 ++++++++++++++++++++++++++++++++++++++ ordo/connection/sudo.scm | 49 +++++++++++++++++++++++++++++ ordo/util/flatten.scm | 10 ++++++ ordo/util/keyword-args.scm | 27 ++++++++++++++++ ordo/util/read-lines.scm | 11 +++++++ ordo/util/shell-quote.scm | 57 ++++++++++++++++++++++++++++++++++ 9 files changed, 337 insertions(+) create mode 100644 ordo/connection.scm create mode 100644 ordo/connection/base.scm create mode 100644 ordo/connection/local.scm create mode 100644 ordo/connection/ssh.scm create mode 100644 ordo/connection/sudo.scm create mode 100644 ordo/util/flatten.scm create mode 100644 ordo/util/keyword-args.scm create mode 100644 ordo/util/read-lines.scm create mode 100644 ordo/util/shell-quote.scm diff --git a/ordo/connection.scm b/ordo/connection.scm new file mode 100644 index 0000000..c871fe9 --- /dev/null +++ b/ordo/connection.scm @@ -0,0 +1,59 @@ +(define-module (ordo connection) + #:use-module (ice-9 exceptions) + #:use-module (oop goops) + #:use-module (ordo connection base) + #:use-module (ordo connection local) + #:use-module (ordo connection ssh) + #:use-module (ordo connection sudo) + #:use-module (ordo logger) + #:use-module (ordo util flatten) + #:use-module (ordo util keyword-args) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:export (connection? + local-connection + ssh-connection + call-with-connection + run) + #:re-export (remote-exec with-remote-input-file with-remote-output-file)) + +(define (connection? c) + (is-a? c )) + +(define (local-connection) + (make )) + +(define* (ssh-connection user host #:key (password #f) (identity #f) (authenticate-server? #t)) + (make #:user user #:host host #:password password + #:identity identity #:authenticate-server? authenticate-server?)) + +(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password) + (when (and sudo? (not (is-a? conn ))) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) + (set! (become? conn) sudo?) + (set! (become-user conn) sudo-user) + (set! (become-password conn) sudo-password) + (dynamic-wind + (lambda () (setup conn)) + (lambda () (proc conn)) + (lambda () (teardown conn)))) + +(define (run conn prog . args) + (let* ((args options (break keyword? args)) + (args (remove unspecified? (flatten args))) + (return (keyword-arg options #:return identity)) + (check? (keyword-arg options #:check?)) + (command (build-command conn prog args options))) + (log-msg 'INFO "Running command: " command) + (let ((out rc (remote-exec conn command))) + (log-msg 'INFO "Command exit code: " rc) + (if check? + (if (zero? rc) + (return out) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) + (values (return out) rc))))) diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm new file mode 100644 index 0000000..daedcca --- /dev/null +++ b/ordo/connection/base.scm @@ -0,0 +1,40 @@ +(define-module (ordo connection base) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (ordo util flatten) + #:use-module (ordo util keyword-args) + #:use-module (ordo util shell-quote) + #:use-module ((srfi srfi-1) #:select (remove)) + #:export ( + setup + teardown + build-command + remote-exec + with-remote-input-file + with-remote-output-file)) + +(define-generic setup) +(define-generic teardown) +(define-generic build-command) +(define-generic remote-exec) +(define-generic with-remote-input-file) +(define-generic with-remote-output-file) + +(define-class ()) + +(define-method (setup (c )) #t) + +(define-method (teardown (c )) #t) + +(define-method (build-command (c ) (prog-name ) (prog-args ) (options )) + (let* ((pwd (keyword-arg options #:pwd)) + (env (keyword-arg options #:env)) + (redirect-err? (keyword-arg options #:redirect-err?)) + (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-name + (map string-shell-quote prog-args) + (when redirect-err? "2>&1")))))) + (string-join xs " "))) diff --git a/ordo/connection/local.scm b/ordo/connection/local.scm new file mode 100644 index 0000000..7eb9eb7 --- /dev/null +++ b/ordo/connection/local.scm @@ -0,0 +1,21 @@ +(define-module (ordo connection local) + #:use-module (ice-9 popen) + #:use-module (oop goops) + #:use-module (ordo connection base) + #:use-module (ordo connection sudo) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class ()) + +(define-method (remote-exec (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 (with-remote-input-file (c ) (filename ) (proc )) + (call-with-input-file filename proc)) + +(define-method (with-remote-output-file (c ) (filename ) (proc )) + (call-with-output-file filename proc)) diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm new file mode 100644 index 0000000..c71f2d4 --- /dev/null +++ b/ordo/connection/ssh.scm @@ -0,0 +1,63 @@ +(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 connection sudo) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class () + (user #:getter ssh-connection-user #:init-keyword #:user) + (host #:getter ssh-connection-host #:init-keyword #:host) + (password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f) + (identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f) + (authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t) + (session) + (sftp-session)) + +(define-method (setup (c )) + (unless (slot-bound? c 'session) + (slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c))) + (when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c)))) + (let ((s (slot-ref c 'session))) + (unless (connected? s) + (connect! s) + (when (ssh-connection-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-connection-password c) + (userauth-password! s (ssh-connection-password c)) + (userauth-public-key/auto! s)))) + (unless (equal? 'success user-auth) + (error (format #f "userauth: ~a" user-auth))))))) + +(define-method (remote-exec (c ) (command )) + (let* ((channel (open-remote-input-pipe (slot-ref c 'session) 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) + (slot-set! c 'sftp-session (make-sftp-session (session c)))) + (slot-ref c 'sftp-session)) + +(define-method (with-remote-input-file (c ) (filename ) (proc )) + (call-with-remote-input-file (sftp-session c) filename proc)) + +(define-method (with-remote-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 (slot-ref c session))) + (when (connected? s) + (disconnect! s))))) diff --git a/ordo/connection/sudo.scm b/ordo/connection/sudo.scm new file mode 100644 index 0000000..ccb3732 --- /dev/null +++ b/ordo/connection/sudo.scm @@ -0,0 +1,49 @@ +(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 ( + become? + become-user + become-password)) + +(define-class () + (become? #:accessor become? #:init-keyword become? #:init-form #f) + (become-user #:accessor become-user #:init-keyword #:become-user #:init-form #f) + (become-password #:accessor become-password #:init-keyword #:become-password #:init-form #f) + (password-tmp-file #:accessor password-tmp-file)) + +(define-method (setup (conn )) + (when (become-password conn) + (let ((out rc (exec conn "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))) + (call-with-output-file conn tmp-file (cut write-line (become-password conn) <>)) + (set! (password-tmp-file conn) tmp-file))))) + +(define-method (build-command (conn ) (prog-name ) (prog-args ) (options )) + (cond + ((not (become? conn)) + (next-method)) + + ((and (become-user conn) (become-password conn)) + (format #f "cat ~a - | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method))) + + ((become-password conn) + (format #f "cat ~a - | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method))) + + ((become-user conn) + (format #f "sudo -k -n -H -u ~a -- ~a" (string-shell-quote (become-user conn)) (next-method))) + + (else (format #f "sudo -k -n -H -- ~a" (next-method))))) + +(define-method (teardown (conn )) + (when (slot-bound? conn 'password-tmp-file) + (exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn)))))) diff --git a/ordo/util/flatten.scm b/ordo/util/flatten.scm new file mode 100644 index 0000000..a37c788 --- /dev/null +++ b/ordo/util/flatten.scm @@ -0,0 +1,10 @@ +(define-module (ordo util flatten) + #:export (flatten)) + +(define (flatten lst) + (cond + ((null? lst) '()) + ((list? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))) + (else + (cons (car lst) (flatten (cdr lst)))))) diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm new file mode 100644 index 0000000..76441c1 --- /dev/null +++ b/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/ordo/util/read-lines.scm b/ordo/util/read-lines.scm new file mode 100644 index 0000000..def581d --- /dev/null +++ b/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) '())) diff --git a/ordo/util/shell-quote.scm b/ordo/util/shell-quote.scm new file mode 100644 index 0000000..5de60fa --- /dev/null +++ b/ordo/util/shell-quote.scm @@ -0,0 +1,57 @@ +;; This file is part of Ordo. +;; +;; Shell quoting implementation is based on Perl's String::ShellQuote +;; Copyright (c) 1997 Roderick Schertler. +;; +;; Guile implementation Copyright (c) 2025 Ray Miller. +;; +;; Ordo is free software: you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) +;; any later version. +;; +;; Ordo is distributed in the hope that it will be useful, but WITHOUT ANY +;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +;; A PARTICULAR PURPOSE. See the GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License along with +;; Ordo. If not, see . + +(define-module (ordo util shell-quote) + #:use-module (rx irregex) + #:use-module ((srfi srfi-197) #:select (chain)) + #:export (string-shell-quote)) + +(define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^"))))) + +(define (needs-escape? s) + (irregex-search unsafe-characters s)) + +(define (squash-quotes m) + (let ((n (/ (- (irregex-match-end-index m) + (irregex-match-start-index m)) + 4))) + (list->string (append + '(#\' #\") + (make-list n #\') + '(#\" #\'))))) + +(define (escape s) + (chain s + ;; ' -> '\'' + (irregex-replace/all (irregex "'") _ "'\\''") + ;; make multiple ' in a row look simpler + ;; '\'''\'''\'' -> '"'''"' + (irregex-replace/all (irregex '(>= 2 "'\\''")) _ squash-quotes) + ;; wrap in single quotes + (string-append "'" _ "'") + ;; kill leading/trailing pair of single quotes + (irregex-replace (irregex '(seq bos "''")) _ "") + (irregex-replace (irregex '(seq "''" eos)) _ ""))) + +(define (string-shell-quote s) + "Quote strings for passing through the shell" + (cond + ((zero? (string-length s)) "''") + ((needs-escape? s) (escape s)) + (else s)))