80 lines
3 KiB
Scheme
80 lines
3 KiB
Scheme
#|
|
|
This file is part of Ordo.
|
|
|
|
Copyright (C) 2025 Ray Miller
|
|
|
|
This program 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, version 3.
|
|
|
|
This program 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
|
|
this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|#
|
|
|
|
(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
|
|
remote-cmd)
|
|
#: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 host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)
|
|
(sudo? #f) (sudo-user #f) (sudo-password #f))
|
|
(make <ssh-connection> #:user user #:host host #:password password
|
|
#:identity identity #:authenticate-server? authenticate-server?
|
|
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))
|
|
|
|
(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
|
|
(let ((conn (deep-clone conn)))
|
|
(when sudo?
|
|
(unless (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 (remote-cmd 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)))))
|