ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Start to rework sudo handling

Browse source
This commit is contained in:
Ray Miller 2025-01-17 10:06:03 +00:00
parent 7f507c8e6d
commit c9db388914
Signed by: ray
GPG key ID: 043F786C4CD681B8
1 changed files with 124 additions and 75 deletions
Download patch file Download diff file Expand all files Collapse all files

199
modules/ordo/connection.scm
View file

@ -18,60 +18,14 @@
#:export (<connection>
local-connection
ssh-connection
init-connection!
close-connection!
setup
teardown
connection-run
connection-call-with-input-file
connection-call-with-output-file
call-with-connection
run))
(define-class <connection> ()
(sudo #:getter sudo? #:init-keyword #:sudo))
(define-class <local-connection> (<connection>))
(define* (local-connection #:key (sudo? #f))
(make <local-connection> #:sudo sudo?))
(define-class <ssh-connection> (<connection>)
(user #:getter get-user #:init-keyword #:user)
(host #:getter get-host #:init-keyword #:host)
(session #:getter get-session #:setter set-session!)
(sftp-session #:getter get-sftp-session #:setter set-sftp-session!))
(define* (ssh-connection user host #:key (sudo? #f))
(make <ssh-connection> #:user user #:host host #:sudo sudo?))
(define-method (init-connection! (c <connection>)) #f)
(define-method (close-connection! (c <connection>)) #f)
(define-method (init-connection! (c <ssh-connection>))
(unless (slot-bound? c 'session)
(set-session! c (make-session #:user (get-user c) #:host (get-host c))))
(let ((s (get-session c)))
(unless (connected? s)
(connect! s)
(let ((server-auth (authenticate-server s)))
(unless (equal? 'ok server-auth)
(error (format #f "authenticate-server: ~a" server-auth))))
(let ((user-auth (userauth-public-key/auto! s)))
(unless (equal? 'success user-auth)
(error (format #f "userauth-public-key: ~a" user-auth))))))
#t)
(define-method (sftp-session (c <ssh-connection>))
(unless (slot-bound? c 'sftp-session)
(set-sftp-session! c (make-sftp-session (get-session c))))
(get-sftp-session c))
(define-method (close-connection! (c <ssh-connection>))
(when (slot-bound? c 'session)
(let ((s (get-session c)))
(when (connected? s)
(disconnect! s)))))
(define (read-lines port)
(define (loop line result)
(if (eof-object? line)
@ -79,6 +33,126 @@
(loop (read-line port) (cons line result))))
(loop (read-line port) '()))
(define-class <connection> ())
(define-class <local-connection> (<connection>))
(define-method (setup (c <connection>)) #f)
(define-method (teardown (c <connection>)) #f)
(define (local-connection)
(make <local-connection>))
(define-method (connection-run (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 (connection-call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-input-file filename proc))
(define-method (connection-call-with-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-output-file filename proc))
(define-class <ssh-connection> (<connection>)
(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 <ssh-connection> #:user user #:host host #:password password #:identity identity #:authenticate-server? authenticate-server))
(define-method (setup (c <ssh-connection>))
(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 <ssh-connection>) (command <string>))
(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 <ssh-connection>))
(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 <ssh-connection>) (filename <string>) (proc <procedure>))
(call-with-remote-input-file (sftp-session c) filename proc))
(define-method (connection-call-with-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 (get-session c)))
(when (connected? s)
(disconnect! s)))))
(define-class <sudo> (<connection>)
(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 <sudo>))
(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 <sudo>))
(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 <sudo>))
(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 <sudo>) (command <string>))
(let ((command (string-append (sudo-command c) " -- " command)))
(connection-run (parent-connection c) command)))
(define-method (connection-call-with-input-file (c <sudo>) (filename <string>) (proc <procedure>))
(connection-call-with-input-file (parent-connection c) filename proc))
(define-method (connection-call-with-output-file (c <sudo>) (filename <string>) (proc <procedure>))
(connection-call-with-output-file (parent-connection c) filename proc))
(define-method (build-command (c <connection>) pwd env prog args)
(let ((cmd (chain-when (list (if (sudo? c) "sudo" "env"))
(pwd (append _ (list "--chdir" pwd)))
@ -91,38 +165,13 @@
(log-msg 'INFO "Running command: " cmd)
cmd))
(define-method (connection-run (c <local-connection>) pwd env prog args)
(let* ((cmd (build-command c pwd env prog args))
(port (open-input-pipe cmd))
(output (read-lines port))
(exit-status (status:exit-val (close-pipe port))))
(values output exit-status)))
(define-method (connection-run (c <ssh-connection>) pwd env prog args)
(let* ((cmd (build-command c pwd env prog args))
(channel (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-method (connection-call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-input-file filename proc))
(define-method (connection-call-with-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
(call-with-remote-input-file (sftp-session c) filename proc))
(define-method (connection-call-with-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-output-file filename proc))
(define-method (connection-call-with-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
(call-with-remote-output-file (sftp-session c) filename proc))
(define (call-with-connection c proc)
(dynamic-wind
(lambda () (init-connection! c))
(lambda () (setup c))
(lambda () (proc c))
(lambda () (close-connection! c))))
(lambda () (teardown c))))
(define* (keyword-arg kw args #:optional (default #f))
(cond