Factor out connection types into different files
This commit is contained in:
parent
c9db388914
commit
d16df7616f
GPG key ID:
043F786C4CD681B8
7 changed files with 251 additions and 168 deletions
|
|
@ -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 (<connection>
|
||||
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 <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)))
|
||||
(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 <local-connection>))
|
||||
((#:ssh) (apply make <ssh-connection>
|
||||
(select-keyword-args kwargs '(#:user #:host #:password #:identity #:authenticate-server?))))))
|
||||
(c (if (keyword-arg kwargs #:sudo?)
|
||||
(apply make <sudo-connection> #: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)
|
||||
|
|
|
|||
23
modules/ordo/connection/base.scm
Normal file
23
modules/ordo/connection/base.scm
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
(define-module (ordo connection base)
|
||||
#:use-module (oop goops)
|
||||
#:export (<connection>
|
||||
conn:validate
|
||||
conn:setup
|
||||
conn:teardown
|
||||
conn:run
|
||||
conn:call-with-input-file
|
||||
conn:call-with-output-file))
|
||||
|
||||
(define-class <connection> ())
|
||||
|
||||
(define-method (conn:validate (c <connection>)) #t)
|
||||
|
||||
(define-method (conn:setup (c <connection>)) #t)
|
||||
|
||||
(define-method (conn:teardown (c <connection>)) #t)
|
||||
|
||||
(define-generic conn:run)
|
||||
|
||||
(define-generic conn:call-with-input-file)
|
||||
|
||||
(define-generic conn:call-with-output-file)
|
||||
20
modules/ordo/connection/local.scm
Normal file
20
modules/ordo/connection/local.scm
Normal file
|
|
@ -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 (<local-connection>))
|
||||
|
||||
(define-class <local-connection> (<connection>))
|
||||
|
||||
(define-method (conn: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 (conn:call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-input-file filename proc))
|
||||
|
||||
(define-method (conn:call-with-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-output-file filename proc))
|
||||
74
modules/ordo/connection/ssh.scm
Normal file
74
modules/ordo/connection/ssh.scm
Normal file
|
|
@ -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 (<ssh-connection>))
|
||||
|
||||
(define-class <ssh-connection> (<connection>)
|
||||
(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 <ssh-connection>))
|
||||
(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 <ssh-connection>))
|
||||
(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 <ssh-connection>) (command <string>))
|
||||
(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 <ssh-connection>))
|
||||
(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 <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-input-file (sftp-session c) filename proc))
|
||||
|
||||
(define-method (conn:call-with-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-output-file (sftp-session c) filename proc))
|
||||
|
||||
(define-method (conn:teardown (c <ssh-connection>))
|
||||
(when (slot-bound? c 'session)
|
||||
(let ((s (session c)))
|
||||
(when (connected? s)
|
||||
(disconnect! s)))))
|
||||
60
modules/ordo/connection/sudo.scm
Normal file
60
modules/ordo/connection/sudo.scm
Normal file
|
|
@ -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 (<sudo-connection>))
|
||||
|
||||
(define-class <sudo-connection> (<connection>)
|
||||
(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 <sudo-connection>))
|
||||
(conn:validate (connection c)))
|
||||
|
||||
(define-method (conn:setup (c <sudo-connection>))
|
||||
(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 <sudo-connection>))
|
||||
(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 <sudo-connection>))
|
||||
(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 <sudo-connection>) (command <string>))
|
||||
(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 <sudo-connection>) (filename <string>) (proc <procedure>))
|
||||
(conn:call-with-input-file (connection c) filename proc))
|
||||
|
||||
(define-method (conn:call-with-output-file (c <sudo-connection>) (filename <string>) (proc <procedure>))
|
||||
(conn:call-with-output-file (connection c) filename proc))
|
||||
27
modules/ordo/util/keyword-args.scm
Normal file
27
modules/ordo/util/keyword-args.scm
Normal file
|
|
@ -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")))))
|
||||
11
modules/ordo/util/read-lines.scm
Normal file
11
modules/ordo/util/read-lines.scm
Normal file
|
|
@ -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) '()))
|
||||
Loading…
Add table
Add a link
Reference in a new issue