me
/
guix
Archived
1
0
Fork 0
Code

offload: Comment out attempt to set up an lsh gateway. 

* guix/scripts/offload.scm (open-ssh-gateway): Comment out.
  (process-request): Remove call to 'open-ssh-gateway' and to 'kill'.
master
Ludovic Courtès 2014-03-01 12:24:39 +01:00
parent aedbf9b873
commit 1f7fd80032
1 changed files with 57 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
guix/scripts/offload.scm
View File

@ -122,38 +122,40 @@ determined."
(leave (_ "failed to load machine file '~a': ~s~%") (leave (_ "failed to load machine file '~a': ~s~%")
file args)))))) file args))))))
(define (open-ssh-gateway machine) ;;; FIXME: The idea was to open the connection to MACHINE once for all, but
"Initiate an SSH connection gateway to MACHINE, and return the PID of the ;;; lshg is currently non-functional.
running lsh gateway upon success, or #f on failure." ;; (define (open-ssh-gateway machine)
(catch 'system-error ;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the
(lambda () ;; running lsh gateway upon success, or #f on failure."
(let* ((port (open-pipe* OPEN_READ %lsh-command ;; (catch 'system-error
"-l" (build-machine-user machine) ;; (lambda ()
"-i" (build-machine-private-key machine) ;; (let* ((port (open-pipe* OPEN_READ %lsh-command
;; XXX: With lsh 2.1, passing '--write-pid' ;; "-l" (build-machine-user machine)
;; last causes the PID not to be printed. ;; "-i" (build-machine-private-key machine)
"--write-pid" "--gateway" "--background" "-z" ;; ;; XXX: With lsh 2.1, passing '--write-pid'
(build-machine-name machine))) ;; ;; last causes the PID not to be printed.
(line (read-line port)) ;; "--write-pid" "--gateway" "--background" "-z"
(status (close-pipe port))) ;; (build-machine-name machine)))
(if (zero? status) ;; (line (read-line port))
(let ((pid (string->number line))) ;; (status (close-pipe port)))
(if (integer? pid) ;; (if (zero? status)
pid ;; (let ((pid (string->number line)))
(begin ;; (if (integer? pid)
(warning (_ "'~a' did not write its PID on stdout: ~s~%") ;; pid
%lsh-command line) ;; (begin
#f))) ;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
(begin ;; %lsh-command line)
(warning (_ "failed to initiate SSH connection to '~a':\ ;; #f)))
'~a' exited with ~a~%") ;; (begin
(build-machine-name machine) ;; (warning (_ "failed to initiate SSH connection to '~a':\
%lsh-command ;; '~a' exited with ~a~%")
(status:exit-val status)) ;; (build-machine-name machine)
#f)))) ;; %lsh-command
(lambda args ;; (status:exit-val status))
(leave (_ "failed to execute '~a': ~a~%") ;; #f))))
%lsh-command (strerror (system-error-errno args)))))) ;; (lambda args
;; (leave (_ "failed to execute '~a': ~a~%")
;; %lsh-command (strerror (system-error-errno args))))))
(define (remote-pipe machine mode command) (define (remote-pipe machine mode command)
"Run COMMAND on MACHINE, assuming an lsh gateway has been set up." "Run COMMAND on MACHINE, assuming an lsh gateway has been set up."
@ -324,8 +326,7 @@ allowed on MACHINE."
(features features))) (features features)))
(machine (choose-build-machine reqs (build-machines)))) (machine (choose-build-machine reqs (build-machines))))
(if machine (if machine
(match (open-ssh-gateway machine) (begin
((? integer? pid)
(display "# accept\n") (display "# accept\n")
(let ((inputs (string-tokenize (read-line))) (let ((inputs (string-tokenize (read-line)))
(outputs (string-tokenize (read-line)))) (outputs (string-tokenize (read-line))))
@ -335,7 +336,6 @@ allowed on MACHINE."
#:print-build-trace? print-build-trace? #:print-build-trace? print-build-trace?
#:max-silent-time max-silent-time #:max-silent-time max-silent-time
#:build-timeout build-timeout))) #:build-timeout build-timeout)))
(kill pid SIGTERM)
(if (zero? status) (if (zero? status)
(begin (begin
(retrieve-files outputs machine) (retrieve-files outputs machine)
@ -350,8 +350,6 @@ with exit code ~a~%"
(build-machine-name machine) (build-machine-name machine)
(status:exit-val status)) (status:exit-val status))
(primitive-exit (status:exit-val status)))))))) (primitive-exit (status:exit-val status))))))))
(#f
(display "# decline\n")))
(display "# decline\n")))) (display "# decline\n"))))
(define-syntax-rule (with-nar-error-handling body ...) (define-syntax-rule (with-nar-error-handling body ...)