[jackhill/guix/guix.git] / guix / ssh.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix ssh)
  #:use-module (guix store)
  #:use-module (guix inferior)
  #:use-module (guix i18n)
  #:use-module ((guix utils) #:select (&fix-hint))
  #:use-module (gcrypt pk-crypto)
  #:use-module (ssh session)
  #:use-module (ssh auth)
  #:use-module (ssh key)
  #:use-module (ssh channel)
  #:use-module (ssh popen)
  #:use-module (ssh session)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 binary-ports)
  #:export (open-ssh-session
            remote-inferior
            remote-daemon-channel
            connect-to-remote-daemon
            remote-system
            remote-authorize-signing-key
            send-files
            retrieve-files
            retrieve-files*
            remote-store-host

            report-guile-error
            report-module-error))

;;; Commentary:
;;;
;;; This module provides tools to support communication with remote stores
;;; over SSH, using Guile-SSH.
;;;
;;; Code:

(define %compression
  "zlib@openssh.com,zlib")

(define* (open-ssh-session host #:key user port identity
                           (compression %compression))
  "Open an SSH session for HOST and return it.  IDENTITY specifies the file
name of a private key to use for authenticating with the host.  When USER,
PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
specifies; otherwise use them.  Throw an error on failure."
  (let ((session (make-session #:user user
                               #:identity identity
                               #:host host
                               #:port port
                               #:timeout 10       ;seconds
                               ;; #:log-verbosity 'protocol

                               ;; We need lightweight compression when
                               ;; exchanging full archives.
                               #:compression compression
                               #:compression-level 3)))

    ;; Honor ~/.ssh/config.
    (session-parse-config! session)

    (match (connect! session)
      ('ok
       ;; Use public key authentication, via the SSH agent if it's available.
       (match (userauth-public-key/auto! session)
         ('success
          session)
         (x
          (disconnect! session)
          (raise (condition
                  (&message
                   (message (format #f (G_ "SSH authentication failed for '~a': ~a~%")
                                    host (get-error session)))))))))
      (x
       ;; Connection failed or timeout expired.
       (raise (condition
               (&message
                (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
                                 host (get-error session))))))))))

(define* (remote-inferior session #:optional become-command)
  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
given, use that to invoke the remote Guile REPL."
  (let* ((repl-command (append (or become-command '())
                               '("guix" "repl" "-t" "machine")))
         (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
    ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
    ;; process does succeed. This doesn't reflect the documentation, so it's
    ;; possible that it's a bug in guile-ssh.
    (when (eof-object? (peek-char pipe))
      (raise (condition
              (&message
               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
                                repl-command))))))
    (port->inferior pipe)))

(define* (inferior-remote-eval exp session #:optional become-command)
  "Evaluate EXP in a new inferior running in SESSION, and close the inferior
right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
REPL."
  (let ((inferior (remote-inferior session become-command)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (inferior-eval exp inferior))
      (lambda ()
        ;; Close INFERIOR right away to prevent finalization from happening in
        ;; another thread at the wrong time (see
        ;; <https://bugs.gnu.org/26976>.)
        (close-inferior inferior)))))

(define* (remote-daemon-channel session
                                #:optional
                                (socket-name
                                 "/var/guix/daemon-socket/socket"))
  "Return an input/output port (an SSH channel) to the daemon at SESSION."
  (define redirect
    ;; Code run in SESSION to redirect the remote process' stdin/stdout to the
    ;; daemon's socket, à la socat.  The SSH protocol supports forwarding to
    ;; Unix-domain sockets but libssh doesn't have an API for that, hence this
    ;; hack.
    `(begin
       (use-modules (ice-9 match) (rnrs io ports)
                    (rnrs bytevectors))

       (let ((sock    (socket AF_UNIX SOCK_STREAM 0))
             (stdin   (current-input-port))
             (stdout  (current-output-port))
             (select* (lambda (read write except)
                        ;; This is a workaround for
                        ;; <https://bugs.gnu.org/30365> in Guile < 2.2.4:
                        ;; since 'select' sometimes returns non-empty sets for
                        ;; no good reason, call 'select' a second time with a
                        ;; zero timeout to filter out incorrect replies.
                        (match (select read write except)
                          ((read write except)
                           (select read write except 0))))))
         (setvbuf stdout 'none)

         ;; Use buffered ports so that 'get-bytevector-some' returns up to the
         ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
         (setvbuf stdin 'block 65536)
         (setvbuf sock 'block 65536)

         (connect sock AF_UNIX ,socket-name)

         (let loop ()
           (match (select* (list stdin sock) '() '())
             ((reads () ())
              (when (memq stdin reads)
                (match (get-bytevector-some stdin)
                  ((? eof-object?)
                   (primitive-exit 0))
                  (bv
                   (put-bytevector sock bv)
                   (force-output sock))))
              (when (memq sock reads)
                (match (get-bytevector-some sock)
                  ((? eof-object?)
                   (primitive-exit 0))
                  (bv
                   (put-bytevector stdout bv))))
              (loop))
             (_
              (primitive-exit 1)))))))

  (open-remote-pipe* session OPEN_BOTH
                     ;; Sort-of shell-quote REDIRECT.
                     "guile" "-c"
                     (object->string
                      (object->string redirect))))

(define* (connect-to-remote-daemon session
                                   #:optional
                                   (socket-name
                                    "/var/guix/daemon-socket/socket"))
  "Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
an SSH session.  Return a <store-connection> object."
  (open-connection #:port (remote-daemon-channel session socket-name)))


(define (store-import-channel session)
  "Return an output port to which archives to be exported to SESSION's store
can be written."
  ;; Using the 'import-paths' RPC on a remote store would be slow because it
  ;; makes a round trip every time 32 KiB have been transferred.  This
  ;; procedure instead opens a separate channel to use the remote
  ;; 'import-paths' procedure, which consumes all the data in a single round
  ;; trip.  This optimizes the successful case at the expense of error
  ;; conditions: errors can only be reported once all the input has been
  ;; consumed.
  (define import
    `(begin
       (use-modules (guix) (srfi srfi-34)
                    (rnrs io ports) (rnrs bytevectors))

       (define (consume-input port)
         (let ((bv (make-bytevector 32768)))
           (let loop ()
             (let ((n (get-bytevector-n! port bv 0
                                         (bytevector-length bv))))
               (unless (eof-object? n)
                 (loop))))))

       ;; Upon completion, write an sexp that denotes the status.
       (write
        (catch #t
          (lambda ()
            (guard (c ((nix-protocol-error? c)
                       ;; Consume all the input since the only time we can
                       ;; report the error is after everything has been
                       ;; consumed.
                       (consume-input (current-input-port))
                       (list 'protocol-error (nix-protocol-error-message c))))
              (with-store store
                (setvbuf (current-input-port) 'none)
                (import-paths store (current-input-port))
                '(success))))
          (lambda args
            (cons 'error args))))))

  (open-remote-pipe session
                    (string-join
                     `("guile" "-c"
                       ,(object->string (object->string import))))
                    OPEN_BOTH))

(define* (store-export-channel session files
                               #:key recursive?)
  "Return an input port from which an export of FILES from SESSION's store can
be read.  When RECURSIVE? is true, the closure of FILES is exported."
  ;; Same as above: this is more efficient than calling 'export-paths' on a
  ;; remote store.
  (define export
    `(begin
       (eval-when (load expand eval)
         (unless (resolve-module '(guix) #:ensure #f)
           (write `(module-error))
           (exit 7)))

       (use-modules (guix) (srfi srfi-1)
                    (srfi srfi-26) (srfi srfi-34))

       (guard (c ((nix-connection-error? c)
                  (write `(connection-error ,(nix-connection-error-file c)
                                            ,(nix-connection-error-code c))))
                 ((nix-protocol-error? c)
                  (write `(protocol-error ,(nix-protocol-error-status c)
                                          ,(nix-protocol-error-message c))))
                 (else
                  (write `(exception))))
         (with-store store
           (let* ((files ',files)
                  (invalid (remove (cut valid-path? store <>)
                                   files)))
             (unless (null? invalid)
               (write `(invalid-items ,invalid))
               (exit 1))

             ;; TODO: When RECURSIVE? is true, we could send the list of store
             ;; items in the closure so that the other end can filter out
             ;; those it already has.

             (write '(exporting))                 ;we're ready
             (force-output)

             (setvbuf (current-output-port) 'none)
             (export-paths store files (current-output-port)
                           #:recursive? ,recursive?))))))

  (open-remote-input-pipe session
                          (string-join
                           `("guile" "-c"
                             ,(object->string
                               (object->string export))))))

(define (remote-system session)
  "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of
the machine on the other end of SESSION."
  (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
                        session))

(define (remote-authorize-signing-key key session)
  "Send KEY, a canonical sexp containing a public key, over SESSION and add it
to the system ACL file if it has not yet been authorized."
  (inferior-remote-eval
   `(begin
      (use-modules (guix build utils)
                   (guix pki)
                   (guix utils)
                   (gcrypt pk-crypto)
                   (srfi srfi-26))

      (define acl (current-acl))
      (define key (string->canonical-sexp ,(canonical-sexp->string key)))

      (unless (authorized-key? key)
        (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
          (mkdir-p (dirname %acl-file))
          (with-atomic-file-output %acl-file
            (cut write-acl acl <>)))))
   session))

(define* (send-files local files remote
                     #:key
                     recursive?
                     (log-port (current-error-port)))
  "Send the subset of FILES from LOCAL (a local store) that's missing to
REMOTE, a remote store.  When RECURSIVE? is true, send the closure of FILES.
Return the list of store items actually sent."
  ;; Compute the subset of FILES missing on SESSION and send them.
  (let* ((files   (if recursive? (requisites local files) files))
         (session (channel-get-session (store-connection-socket remote)))
         (missing (inferior-remote-eval
                   `(begin
                      (use-modules (guix)
                                   (srfi srfi-1) (srfi srfi-26))

                      (with-store store
                        (remove (cut valid-path? store <>)
                                ',files)))
                   session))
         (count   (length missing))
         (sizes   (map (lambda (item)
                         (path-info-nar-size (query-path-info local item)))
                       missing))
         (port    (store-import-channel session)))
    (format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%"
                         "sending ~a store items (~h MiB) to '~a'...~%" count)
            count
            (inexact->exact (round (/ (reduce + 0 sizes) (expt 2. 20))))
            (session-get session 'host))

    ;; Send MISSING in topological order.
    (export-paths local missing port)

    ;; Tell the remote process that we're done.  (In theory the end-of-archive
    ;; mark of 'export-paths' would be enough, but in practice it's not.)
    (channel-send-eof port)

    ;; Wait for completion of the remote process and read the status sexp from
    ;; PORT.  Wait for the exit status only when 'read' completed; otherwise,
    ;; we might wait forever if the other end is stuck.
    (let* ((result (false-if-exception (read port)))
           (status (and result
                        (zero? (channel-get-exit-status port)))))
      (close-port port)
      (match result
        (('success . _)
         missing)
        (('protocol-error message)
         (raise (condition
                 (&store-protocol-error (message message) (status 42)))))
        (('error key args ...)
         (raise (condition
                 (&store-protocol-error
                  (message (call-with-output-string
                             (lambda (port)
                               (print-exception port #f key args))))
                  (status 43)))))
        (_
         (raise (condition
                 (&store-protocol-error
                  (message "unknown error while sending files over SSH")
                  (status 44)))))))))

(define (remote-store-session remote)
  "Return the SSH channel beneath REMOTE, a remote store as returned by
'connect-to-remote-daemon', or #f."
  (channel-get-session (store-connection-socket remote)))

(define (remote-store-host remote)
  "Return the name of the host REMOTE is connected to, where REMOTE is a
remote store as returned by 'connect-to-remote-daemon'."
  (match (remote-store-session remote)
    (#f #f)
    ((? session? session)
     (session-get session 'host))))

(define* (file-retrieval-port files remote
                              #:key recursive?)
  "Return an input port from which to retrieve FILES (a list of store items)
from REMOTE, along with the number of items to retrieve (lower than or equal
to the length of FILES.)"
  (values (store-export-channel (remote-store-session remote) files
                                #:recursive? recursive?)
          (length files)))            ;XXX: inaccurate when RECURSIVE? is true

(define-syntax raise-error
  (syntax-rules (=>)
    ((_ fmt args ... (=> hint-fmt hint-args ...))
     (raise (condition
             (&message
              (message (format #f fmt args ...)))
             (&fix-hint
              (hint (format #f hint-fmt hint-args ...))))))
    ((_ fmt args ...)
     (raise (condition
             (&message
              (message (format #f fmt args ...))))))))

(define* (retrieve-files* files remote
                          #:key recursive? (log-port (current-error-port))
                          (import (const #f)))
  "Pass IMPORT an input port from which to read the sequence of FILES coming
from REMOTE.  When RECURSIVE? is true, retrieve the closure of FILES."
  (let-values (((port count)
                (file-retrieval-port files remote
                                     #:recursive? recursive?)))
    (match (read port)                            ;read the initial status
      (('exporting)
       (format #t (N_ "retrieving ~a store item from '~a'...~%"
                      "retrieving ~a store items from '~a'...~%" count)
               count (remote-store-host remote))

       (dynamic-wind
         (const #t)
         (lambda ()
           (import port))
         (lambda ()
           (close-port port))))
      ((? eof-object?)
       (report-guile-error (remote-store-host remote)))
      (('module-error . _)
       (report-module-error (remote-store-host remote)))
      (('connection-error file code . _)
       (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a")
                    file (remote-store-host remote) (strerror code)))
      (('invalid-items items . _)
       (raise-error (N_ "no such item on remote host '~A':~{ ~a~}"
                        "no such items on remote host '~A':~{ ~a~}"
                        (length items))
                    (remote-store-host remote) items))
      (('protocol-error status message . _)
       (raise-error (G_ "protocol error on remote host '~A': ~a")
                    (remote-store-host remote) message))
      (_
       (raise-error (G_ "failed to retrieve store items from '~a'")
                    (remote-store-host remote))))))

(define* (retrieve-files local files remote
                         #:key recursive? (log-port (current-error-port)))
  "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on
LOCAL.  When RECURSIVE? is true, retrieve the closure of FILES."
  (retrieve-files* (remove (cut valid-path? local <>) files)
                   remote
                   #:recursive? recursive?
                   #:log-port log-port
                   #:import (lambda (port)
                              (import-paths local port))))

\f
;;;
;;; Error reporting.
;;;

(define (report-guile-error host)
  (raise-error (G_ "failed to start Guile on remote host '~A'") host
               (=> (G_ "Make sure @command{guile} can be found in
@code{$PATH} on the remote host.  Run @command{ssh ~A guile --version} to
check.")
                   host)))

(define (report-module-error host)
  "Report an error about missing Guix modules on HOST."
  ;; TRANSLATORS: Leave "Guile" untranslated.
  (raise-error (G_ "Guile modules not found on remote host '~A'") host
               (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix'
own module directory.  Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to
check.")
                   host)))

;;; ssh.scm ends here
Commit	Line	Data
987a29ba	1	;;; GNU Guix --- Functional package management for GNU
76832d34	2	;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
987a29ba LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (guix ssh)
	20	#:use-module (guix store)
af15fe13	21	#:use-module (guix inferior)
52d174d6	22	#:use-module (guix i18n)
896fec47	23	#:use-module ((guix utils) #:select (&fix-hint))
3033d59a	24	#:use-module (gcrypt pk-crypto)
615c5298 LC	25	#:use-module (ssh session)
	26	#:use-module (ssh auth)
	27	#:use-module (ssh key)
987a29ba LC	28	#:use-module (ssh channel)
	29	#:use-module (ssh popen)
	30	#:use-module (ssh session)
0e3c8528	31	#:use-module (srfi srfi-1)
987a29ba	32	#:use-module (srfi srfi-11)
d06d54e3	33	#:use-module (srfi srfi-26)
13164a21 LC	34	#:use-module (srfi srfi-34)
13164a21 LC	35	#:use-module (srfi srfi-35)
987a29ba	36	#:use-module (ice-9 match)
416a7c69	37	#:use-module (ice-9 format)
13164a21	38	#:use-module (ice-9 binary-ports)
615c5298	39	#:export (open-ssh-session
af15fe13	40	remote-inferior
e5378337	41	remote-daemon-channel
615c5298	42	connect-to-remote-daemon
2c8e04f1	43	remote-system
3033d59a	44	remote-authorize-signing-key
987a29ba LC	45	send-files
987a29ba LC	46	retrieve-files
d06d54e3	47	retrieve-files*
4eb0f9ae LC	48	remote-store-host
	49
	50	report-guile-error
	51	report-module-error))
987a29ba LC	52
	53	;;; Commentary:
	54	;;;
	55	;;; This module provides tools to support communication with remote stores
	56	;;; over SSH, using Guile-SSH.
	57	;;;
	58	;;; Code:
	59
615c5298 LC	60	(define %compression
	61	"zlib@openssh.com,zlib")
	62
a9b09ed7	63	(define* (open-ssh-session host #:key user port identity
615c5298	64	(compression %compression))
a9b09ed7 JK	65	"Open an SSH session for HOST and return it. IDENTITY specifies the file
	66	name of a private key to use for authenticating with the host. When USER,
	67	PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
	68	specifies; otherwise use them. Throw an error on failure."
615c5298	69	(let ((session (make-session #:user user
a9b09ed7	70	#:identity identity
615c5298 LC	71	#:host host
	72	#:port port
	73	#:timeout 10 ;seconds
	74	;; #:log-verbosity 'protocol
	75
	76	;; We need lightweight compression when
	77	;; exchanging full archives.
	78	#:compression compression
	79	#:compression-level 3)))
	80
	81	;; Honor ~/.ssh/config.
	82	(session-parse-config! session)
	83
	84	(match (connect! session)
	85	('ok
	86	;; Use public key authentication, via the SSH agent if it's available.
	87	(match (userauth-public-key/auto! session)
	88	('success
	89	session)
	90	(x
	91	(disconnect! session)
	92	(raise (condition
	93	(&message
69daee23	94	(message (format #f (G_ "SSH authentication failed for '~a': ~a~%")
615c5298 LC	95	host (get-error session)))))))))
	96	(x
	97	;; Connection failed or timeout expired.
	98	(raise (condition
	99	(&message
69daee23	100	(message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
615c5298 LC	101	host (get-error session))))))))))
615c5298 LC	102
5ea7537b JK	103	(define* (remote-inferior session #:optional become-command)
	104	"Return a remote inferior for the given SESSION. If BECOME-COMMAND is
	105	given, use that to invoke the remote Guile REPL."
	106	(let* ((repl-command (append (or become-command '())
	107	'("guix" "repl" "-t" "machine")))
	108	(pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
	109	;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
	110	;; process does succeed. This doesn't reflect the documentation, so it's
	111	;; possible that it's a bug in guile-ssh.
	112	(when (eof-object? (peek-char pipe))
	113	(raise (condition
	114	(&message
	115	(message (format #f (G_ "failed to run '~{~a~^ ~}'")
	116	repl-command))))))
af15fe13 LC	117	(port->inferior pipe)))
af15fe13 LC	118
5ea7537b	119	(define* (inferior-remote-eval exp session #:optional become-command)
ed7b4437	120	"Evaluate EXP in a new inferior running in SESSION, and close the inferior
5ea7537b JK	121	right away. If BECOME-COMMAND is given, use that to invoke the remote Guile
	122	REPL."
	123	(let ((inferior (remote-inferior session become-command)))
ed7b4437 LC	124	(dynamic-wind
	125	(const #t)
	126	(lambda ()
	127	(inferior-eval exp inferior))
	128	(lambda ()
	129	;; Close INFERIOR right away to prevent finalization from happening in
	130	;; another thread at the wrong time (see
	131	;; <https://bugs.gnu.org/26976>.)
	132	(close-inferior inferior)))))
	133
e5378337 LC	134	(define* (remote-daemon-channel session
	135	#:optional
	136	(socket-name
	137	"/var/guix/daemon-socket/socket"))
	138	"Return an input/output port (an SSH channel) to the daemon at SESSION."
987a29ba LC	139	(define redirect
	140	;; Code run in SESSION to redirect the remote process' stdin/stdout to the
	141	;; daemon's socket, à la socat. The SSH protocol supports forwarding to
	142	;; Unix-domain sockets but libssh doesn't have an API for that, hence this
	143	;; hack.
	144	`(begin
17af5d51	145	(use-modules (ice-9 match) (rnrs io ports)
0dcf675c	146	(rnrs bytevectors))
987a29ba	147
8446dc5a LC	148	(let ((sock (socket AF_UNIX SOCK_STREAM 0))
	149	(stdin (current-input-port))
	150	(stdout (current-output-port))
	151	(select* (lambda (read write except)
	152	;; This is a workaround for
	153	;; <https://bugs.gnu.org/30365> in Guile < 2.2.4:
	154	;; since 'select' sometimes returns non-empty sets for
	155	;; no good reason, call 'select' a second time with a
	156	;; zero timeout to filter out incorrect replies.
	157	(match (select read write except)
	158	((read write except)
	159	(select read write except 0))))))
76832d34	160	(setvbuf stdout 'none)
0dcf675c LC	161
	162	;; Use buffered ports so that 'get-bytevector-some' returns up to the
	163	;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
76832d34 LC	164	(setvbuf stdin 'block 65536)
76832d34 LC	165	(setvbuf sock 'block 65536)
0dcf675c	166
987a29ba LC	167	(connect sock AF_UNIX ,socket-name)
	168
	169	(let loop ()
8446dc5a	170	(match (select* (list stdin sock) '() '())
55f40fdb	171	((reads () ())
987a29ba	172	(when (memq stdin reads)
0dcf675c LC	173	(match (get-bytevector-some stdin)
0dcf675c LC	174	((? eof-object?)
987a29ba	175	(primitive-exit 0))
0dcf675c LC	176	(bv
	177	(put-bytevector sock bv)
	178	(force-output sock))))
987a29ba	179	(when (memq sock reads)
0dcf675c LC	180	(match (get-bytevector-some sock)
0dcf675c LC	181	((? eof-object?)
987a29ba	182	(primitive-exit 0))
0dcf675c LC	183	(bv
0dcf675c LC	184	(put-bytevector stdout bv))))
987a29ba LC	185	(loop))
	186	(_
	187	(primitive-exit 1)))))))
	188
e5378337 LC	189	(open-remote-pipe* session OPEN_BOTH
	190	;; Sort-of shell-quote REDIRECT.
	191	"guile" "-c"
	192	(object->string
	193	(object->string redirect))))
	194
	195	(define* (connect-to-remote-daemon session
	196	#:optional
	197	(socket-name
	198	"/var/guix/daemon-socket/socket"))
	199	"Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
de9fbe9c	200	an SSH session. Return a <store-connection> object."
2e4d8339	201	(open-connection #:port (remote-daemon-channel session socket-name)))
e5378337	202
987a29ba LC	203
	204	(define (store-import-channel session)
	205	"Return an output port to which archives to be exported to SESSION's store
	206	can be written."
	207	;; Using the 'import-paths' RPC on a remote store would be slow because it
	208	;; makes a round trip every time 32 KiB have been transferred. This
	209	;; procedure instead opens a separate channel to use the remote
	210	;; 'import-paths' procedure, which consumes all the data in a single round
de9d8f0e LC	211	;; trip. This optimizes the successful case at the expense of error
	212	;; conditions: errors can only be reported once all the input has been
	213	;; consumed.
987a29ba LC	214	(define import
987a29ba LC	215	`(begin
de9d8f0e LC	216	(use-modules (guix) (srfi srfi-34)
de9d8f0e LC	217	(rnrs io ports) (rnrs bytevectors))
987a29ba	218
de9d8f0e LC	219	(define (consume-input port)
	220	(let ((bv (make-bytevector 32768)))
	221	(let loop ()
	222	(let ((n (get-bytevector-n! port bv 0
	223	(bytevector-length bv))))
	224	(unless (eof-object? n)
	225	(loop))))))
987a29ba	226
de9d8f0e LC	227	;; Upon completion, write an sexp that denotes the status.
	228	(write
	229	(catch #t
	230	(lambda ()
	231	(guard (c ((nix-protocol-error? c)
	232	;; Consume all the input since the only time we can
	233	;; report the error is after everything has been
	234	;; consumed.
	235	(consume-input (current-input-port))
	236	(list 'protocol-error (nix-protocol-error-message c))))
	237	(with-store store
76832d34	238	(setvbuf (current-input-port) 'none)
de9d8f0e LC	239	(import-paths store (current-input-port))
	240	'(success))))
	241	(lambda args
	242	(cons 'error args))))))
987a29ba	243
de9d8f0e LC	244	(open-remote-pipe session
	245	(string-join
	246	`("guile" "-c"
	247	,(object->string (object->string import))))
	248	OPEN_BOTH))
987a29ba	249
e9629e82 LC	250	(define* (store-export-channel session files
e9629e82 LC	251	#:key recursive?)
987a29ba	252	"Return an input port from which an export of FILES from SESSION's store can
e9629e82	253	be read. When RECURSIVE? is true, the closure of FILES is exported."
987a29ba LC	254	;; Same as above: this is more efficient than calling 'export-paths' on a
	255	;; remote store.
	256	(define export
	257	`(begin
896fec47 LC	258	(eval-when (load expand eval)
	259	(unless (resolve-module '(guix) #:ensure #f)
	260	(write `(module-error))
	261	(exit 7)))
	262
	263	(use-modules (guix) (srfi srfi-1)
	264	(srfi srfi-26) (srfi srfi-34))
	265
	266	(guard (c ((nix-connection-error? c)
	267	(write `(connection-error ,(nix-connection-error-file c)
	268	,(nix-connection-error-code c))))
	269	((nix-protocol-error? c)
	270	(write `(protocol-error ,(nix-protocol-error-status c)
	271	,(nix-protocol-error-message c))))
	272	(else
	273	(write `(exception))))
	274	(with-store store
	275	(let* ((files ',files)
	276	(invalid (remove (cut valid-path? store <>)
	277	files)))
	278	(unless (null? invalid)
	279	(write `(invalid-items ,invalid))
	280	(exit 1))
	281
0e3c8528 LC	282	;; TODO: When RECURSIVE? is true, we could send the list of store
	283	;; items in the closure so that the other end can filter out
	284	;; those it already has.
	285
896fec47 LC	286	(write '(exporting)) ;we're ready
	287	(force-output)
	288
76832d34	289	(setvbuf (current-output-port) 'none)
896fec47 LC	290	(export-paths store files (current-output-port)
896fec47 LC	291	#:recursive? ,recursive?))))))
987a29ba LC	292
	293	(open-remote-input-pipe session
	294	(string-join
	295	`("guile" "-c"
	296	,(object->string
	297	(object->string export))))))
	298
2c8e04f1 JK	299	(define (remote-system session)
	300	"Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of
	301	the machine on the other end of SESSION."
	302	(inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
	303	session))
3033d59a JK	304
	305	(define (remote-authorize-signing-key key session)
	306	"Send KEY, a canonical sexp containing a public key, over SESSION and add it
	307	to the system ACL file if it has not yet been authorized."
	308	(inferior-remote-eval
	309	`(begin
	310	(use-modules (guix build utils)
	311	(guix pki)
	312	(guix utils)
	313	(gcrypt pk-crypto)
	314	(srfi srfi-26))
	315
	316	(define acl (current-acl))
	317	(define key (string->canonical-sexp ,(canonical-sexp->string key)))
	318
	319	(unless (authorized-key? key)
	320	(let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
	321	(mkdir-p (dirname %acl-file))
	322	(with-atomic-file-output %acl-file
	323	(cut write-acl acl <>)))))
	324	session))
2c8e04f1	325
987a29ba	326	(define* (send-files local files remote
e9629e82 LC	327	#:key
	328	recursive?
	329	(log-port (current-error-port)))
987a29ba	330	"Send the subset of FILES from LOCAL (a local store) that's missing to
23973e4f LC	331	REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES.
23973e4f LC	332	Return the list of store items actually sent."
987a29ba	333	;; Compute the subset of FILES missing on SESSION and send them.
e9629e82	334	(let* ((files (if recursive? (requisites local files) files))
de9fbe9c	335	(session (channel-get-session (store-connection-socket remote)))
ed7b4437 LC	336	(missing (inferior-remote-eval
	337	`(begin
	338	(use-modules (guix)
	339	(srfi srfi-1) (srfi srfi-26))
987a29ba	340
ed7b4437 LC	341	(with-store store
	342	(remove (cut valid-path? store <>)
	343	',files)))
	344	session))
987a29ba	345	(count (length missing))
b90d97ec LC	346	(sizes (map (lambda (item)
	347	(path-info-nar-size (query-path-info local item)))
	348	missing))
987a29ba	349	(port (store-import-channel session)))
b90d97ec LC	350	(format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%"
	351	"sending ~a store items (~h MiB) to '~a'...~%" count)
	352	count
	353	(inexact->exact (round (/ (reduce + 0 sizes) (expt 2. 20))))
	354	(session-get session 'host))
987a29ba LC	355
	356	;; Send MISSING in topological order.
	357	(export-paths local missing port)
	358
	359	;; Tell the remote process that we're done. (In theory the end-of-archive
	360	;; mark of 'export-paths' would be enough, but in practice it's not.)
	361	(channel-send-eof port)
	362
de9d8f0e	363	;; Wait for completion of the remote process and read the status sexp from
63fd9f08 LC	364	;; PORT. Wait for the exit status only when 'read' completed; otherwise,
63fd9f08 LC	365	;; we might wait forever if the other end is stuck.
de9d8f0e	366	(let* ((result (false-if-exception (read port)))
63fd9f08 LC	367	(status (and result
63fd9f08 LC	368	(zero? (channel-get-exit-status port)))))
987a29ba	369	(close-port port)
de9d8f0e LC	370	(match result
	371	(('success . _)
	372	missing)
	373	(('protocol-error message)
	374	(raise (condition
f9e8a123	375	(&store-protocol-error (message message) (status 42)))))
de9d8f0e LC	376	(('error key args ...)
de9d8f0e LC	377	(raise (condition
f9e8a123	378	(&store-protocol-error
de9d8f0e LC	379	(message (call-with-output-string
	380	(lambda (port)
	381	(print-exception port #f key args))))
	382	(status 43)))))
	383	(_
	384	(raise (condition
f9e8a123	385	(&store-protocol-error
de9d8f0e LC	386	(message "unknown error while sending files over SSH")
de9d8f0e LC	387	(status 44)))))))))
987a29ba LC	388
	389	(define (remote-store-session remote)
	390	"Return the SSH channel beneath REMOTE, a remote store as returned by
	391	'connect-to-remote-daemon', or #f."
de9fbe9c	392	(channel-get-session (store-connection-socket remote)))
987a29ba LC	393
	394	(define (remote-store-host remote)
	395	"Return the name of the host REMOTE is connected to, where REMOTE is a
	396	remote store as returned by 'connect-to-remote-daemon'."
	397	(match (remote-store-session remote)
	398	(#f #f)
	399	((? session? session)
	400	(session-get session 'host))))
	401
e9629e82 LC	402	(define* (file-retrieval-port files remote
e9629e82 LC	403	#:key recursive?)
987a29ba LC	404	"Return an input port from which to retrieve FILES (a list of store items)
	405	from REMOTE, along with the number of items to retrieve (lower than or equal
	406	to the length of FILES.)"
e9629e82 LC	407	(values (store-export-channel (remote-store-session remote) files
	408	#:recursive? recursive?)
	409	(length files))) ;XXX: inaccurate when RECURSIVE? is true
987a29ba	410
896fec47 LC	411	(define-syntax raise-error
	412	(syntax-rules (=>)
	413	((_ fmt args ... (=> hint-fmt hint-args ...))
	414	(raise (condition
	415	(&message
	416	(message (format #f fmt args ...)))
	417	(&fix-hint
	418	(hint (format #f hint-fmt hint-args ...))))))
	419	((_ fmt args ...)
	420	(raise (condition
	421	(&message
	422	(message (format #f fmt args ...))))))))
	423
d06d54e3 LC	424	(define* (retrieve-files* files remote
	425	#:key recursive? (log-port (current-error-port))
	426	(import (const #f)))
	427	"Pass IMPORT an input port from which to read the sequence of FILES coming
	428	from REMOTE. When RECURSIVE? is true, retrieve the closure of FILES."
987a29ba	429	(let-values (((port count)
e9629e82 LC	430	(file-retrieval-port files remote
e9629e82 LC	431	#:recursive? recursive?)))
896fec47 LC	432	(match (read port) ;read the initial status
	433	(('exporting)
	434	(format #t (N_ "retrieving ~a store item from '~a'...~%"
	435	"retrieving ~a store items from '~a'...~%" count)
	436	count (remote-store-host remote))
	437
d06d54e3 LC	438	(dynamic-wind
	439	(const #t)
	440	(lambda ()
	441	(import port))
	442	(lambda ()
	443	(close-port port))))
896fec47	444	((? eof-object?)
4eb0f9ae	445	(report-guile-error (remote-store-host remote)))
896fec47	446	(('module-error . _)
4eb0f9ae	447	(report-module-error (remote-store-host remote)))
896fec47 LC	448	(('connection-error file code . _)
	449	(raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a")
	450	file (remote-store-host remote) (strerror code)))
	451	(('invalid-items items . _)
	452	(raise-error (N_ "no such item on remote host '~A':~{ ~a~}"
	453	"no such items on remote host '~A':~{ ~a~}"
	454	(length items))
	455	(remote-store-host remote) items))
	456	(('protocol-error status message . _)
	457	(raise-error (G_ "protocol error on remote host '~A': ~a")
	458	(remote-store-host remote) message))
	459	(_
	460	(raise-error (G_ "failed to retrieve store items from '~a'")
	461	(remote-store-host remote))))))
987a29ba	462
d06d54e3 LC	463	(define* (retrieve-files local files remote
	464	#:key recursive? (log-port (current-error-port)))
	465	"Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on
	466	LOCAL. When RECURSIVE? is true, retrieve the closure of FILES."
0e3c8528 LC	467	(retrieve-files* (remove (cut valid-path? local <>) files)
0e3c8528 LC	468	remote
d06d54e3 LC	469	#:recursive? recursive?
	470	#:log-port log-port
	471	#:import (lambda (port)
	472	(import-paths local port))))
	473
4eb0f9ae LC	474	\f
	475	;;;
	476	;;; Error reporting.
	477	;;;
	478
	479	(define (report-guile-error host)
	480	(raise-error (G_ "failed to start Guile on remote host '~A'") host
	481	(=> (G_ "Make sure @command{guile} can be found in
	482	@code{$PATH} on the remote host. Run @command{ssh ~A guile --version} to
	483	check.")
	484	host)))
	485
	486	(define (report-module-error host)
	487	"Report an error about missing Guix modules on HOST."
	488	;; TRANSLATORS: Leave "Guile" untranslated.
	489	(raise-error (G_ "Guile modules not found on remote host '~A'") host
	490	(=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix'
	491	own module directory. Run @command{ssh ~A env \| grep GUILE_LOAD_PATH} to
	492	check.")
	493	host)))
	494
987a29ba	495	;;; ssh.scm ends here