Get rudimentary connections working again

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 <connection>))
+
+(define (local-connection)
+  (make <local-connection>))
+
+(define* (ssh-connection user host #:key (password #f) (identity #f) (authenticate-server? #t))
+  (make <ssh-connection> #: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 <sudo-connection>)))
+    (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)))))

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 (<connection>
+            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 <connection> ())
+
+(define-method (setup (c <connection>)) #t)
+
+(define-method (teardown (c <connection>)) #t)
+
+(define-method (build-command (c <connection>) (prog-name <string>) (prog-args <list>) (options <list>))
+  (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 " ")))

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 (<local-connection>))
+
+(define-class <local-connection> (<sudo-connection>))
+
+(define-method (remote-exec (c <local-connection>) (command <string>))
+  (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 <local-connection>) (filename <string>) (proc <procedure>))
+  (call-with-input-file filename proc))
+
+(define-method (with-remote-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
+  (call-with-output-file filename proc))

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 (<ssh-connection>))
+
+(define-class <ssh-connection> (<sudo-connection>)
+  (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 <ssh-connection>))
+  (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 <ssh-connection>) (command <string>))
+  (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 <ssh-connection>))
+  (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 <ssh-connection>) (filename <string>) (proc <procedure>))
+  (call-with-remote-input-file (sftp-session c) filename proc))
+
+(define-method (with-remote-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
+  (call-with-remote-output-file (sftp-session c) filename proc))
+
+(define-method (teardown (c <ssh-connection>))
+  (when (slot-bound? c 'session)
+    (let ((s (slot-ref c session)))
+      (when (connected? s)
+        (disconnect! s)))))

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 (<sudo-connection>
+            become?
+            become-user
+            become-password))
+
+(define-class <sudo-connection> (<connection>)
+  (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 <sudo-connection>))
+  (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 <sudo-connection>) (prog-name <string>) (prog-args <list>) (options <list>))
+  (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 <sudo-connection>))
+  (when (slot-bound? conn 'password-tmp-file)
+    (exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn))))))

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

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

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

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 <https://www.gnu.org/licenses/>.
+
+(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)))