Ray Miller
93820dc307
Add convenience functions run and must to the context module, and remove the similar functions from connection. In the connection module, rename %run to connection-run now that that function has moved to context.
125 lines
4.6 KiB
Scheme
125 lines
4.6 KiB
Scheme
(define-module (ordo connection)
|
|
#:use-module (oop goops)
|
|
#:use-module (ice-9 popen)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (srfi srfi-1) ; list operations
|
|
#: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 util shell-quote)
|
|
#:export (<connection>
|
|
local-connection
|
|
ssh-connection
|
|
init-connection!
|
|
close-connection!
|
|
connection-run
|
|
connection-call-with-input-file
|
|
connection-call-with-output-file
|
|
call-with-connection))
|
|
|
|
(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)
|
|
(reverse result)
|
|
(loop (read-line port) (cons line result))))
|
|
(loop (read-line port) '()))
|
|
|
|
(define (kw-arg kw kwargs)
|
|
(cond
|
|
((null? (kwargs)) #f)
|
|
((equal? (car kwargs) kw) (cadr kwargs))
|
|
(else (kw-arg kw (cddr kwargs)))))
|
|
|
|
(define-method (build-command (c <connection>) pwd env prog args)
|
|
(let ((cmd (list (if (sudo? c) "sudo" "env"))))
|
|
(chain-when cmd
|
|
(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 _ " ")))))
|
|
|
|
(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 () (proc c))
|
|
(lambda () (close-connection! c))))
|