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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 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 ui) #:select (G_ N_))
  #: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 (ssh dist)
  #:use-module (ssh dist node)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)
  #:export (open-ssh-session
            remote-daemon-channel
            connect-to-remote-daemon
            send-files
            retrieve-files
            remote-store-host

            file-retrieval-port))

;;; 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
                           (compression %compression))
  "Open an SSH session for HOST and return it.  When USER and PORT are #f, use
default values or whatever '~/.ssh/config' specifies; otherwise use them.
Throw an error on failure."
  (let ((session (make-session #:user user
                               #: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-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))

       (let ((sock   (socket AF_UNIX SOCK_STREAM 0))
             (stdin  (current-input-port))
             (stdout (current-output-port)))
         (setvbuf stdin _IONBF)
         (setvbuf stdout _IONBF)
         (connect sock AF_UNIX ,socket-name)

         (let loop ()
           (match (select (list stdin sock) '() (list stdin stdout sock))
             ((reads writes ())
              (when (memq stdin reads)
                (match (get-bytevector-some stdin)
                  ((? eof-object?)
                   (primitive-exit 0))
                  (bv
                   (put-bytevector sock bv))))
              (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 <nix-server> object."
  (open-connection #:port (remote-daemon-channel session)))


(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) _IONBF)
                (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
       (use-modules (guix))

       (with-store store
         (setvbuf (current-output-port) _IONBF)

         ;; FIXME: Exceptions are silently swallowed.  We should report them
         ;; somehow.
         (export-paths store ',files (current-output-port)
                       #:recursive? ,recursive?))))

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

(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 (nix-server-socket remote)))
         (node    (make-node session))
         (missing (node-eval node
                             `(begin
                                (use-modules (guix)
                                             (srfi srfi-1) (srfi srfi-26))

                                (with-store store
                                  (remove (cut valid-path? store <>)
                                          ',files)))))
         (count   (length missing))
         (port    (store-import-channel session)))
    (format log-port (N_ "sending ~a store item to '~a'...~%"
                         "sending ~a store items to '~a'...~%" count)
            count (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.
    (let* ((result (false-if-exception (read port)))
           (status (zero? (channel-get-exit-status port))))
      (close-port port)
      (match result
        (('success . _)
         missing)
        (('protocol-error message)
         (raise (condition
                 (&nix-protocol-error (message message) (status 42)))))
        (('error key args ...)
         (raise (condition
                 (&nix-protocol-error
                  (message (call-with-output-string
                             (lambda (port)
                               (print-exception port #f key args))))
                  (status 43)))))
        (_
         (raise (condition
                 (&nix-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 (nix-server-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* (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."
  (let-values (((port count)
                (file-retrieval-port files remote
                                     #:recursive? recursive?)))
    (format #t (N_ "retrieving ~a store item from '~a'...~%"
                   "retrieving ~a store items from '~a'...~%" count)
            count (remote-store-host remote))
    (when (eof-object? (lookahead-u8 port))
      ;; The failure could be because one of the requested store items is not
      ;; valid on REMOTE, or because Guile or Guix is improperly installed.
      ;; TODO: Improve error reporting.
      (raise (condition
              (&message
               (message
                (format #f
                        (G_ "failed to retrieve store items from '~a'")
                        (remote-store-host remote)))))))

    (let ((result (import-paths local port)))
      (close-port port)
      result)))

;;; ssh.scm ends here
Commit	Line	Data
987a29ba	1	;;; GNU Guix --- Functional package management for GNU
615c5298	2	;;; Copyright © 2016, 2017 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)
69daee23	21	#:use-module ((guix ui) #:select (G_ N_))
615c5298 LC	22	#:use-module (ssh session)
	23	#:use-module (ssh auth)
	24	#:use-module (ssh key)
987a29ba LC	25	#:use-module (ssh channel)
	26	#:use-module (ssh popen)
	27	#:use-module (ssh session)
	28	#:use-module (ssh dist)
	29	#:use-module (ssh dist node)
	30	#:use-module (srfi srfi-11)
13164a21 LC	31	#:use-module (srfi srfi-34)
13164a21 LC	32	#:use-module (srfi srfi-35)
987a29ba	33	#:use-module (ice-9 match)
13164a21	34	#:use-module (ice-9 binary-ports)
615c5298	35	#:export (open-ssh-session
e5378337	36	remote-daemon-channel
615c5298	37	connect-to-remote-daemon
987a29ba LC	38	send-files
	39	retrieve-files
	40	remote-store-host
	41
	42	file-retrieval-port))
	43
	44	;;; Commentary:
	45	;;;
	46	;;; This module provides tools to support communication with remote stores
	47	;;; over SSH, using Guile-SSH.
	48	;;;
	49	;;; Code:
	50
615c5298 LC	51	(define %compression
	52	"zlib@openssh.com,zlib")
	53
	54	(define* (open-ssh-session host #:key user port
	55	(compression %compression))
	56	"Open an SSH session for HOST and return it. When USER and PORT are #f, use
	57	default values or whatever '~/.ssh/config' specifies; otherwise use them.
	58	Throw an error on failure."
	59	(let ((session (make-session #:user user
	60	#:host host
	61	#:port port
	62	#:timeout 10 ;seconds
	63	;; #:log-verbosity 'protocol
	64
	65	;; We need lightweight compression when
	66	;; exchanging full archives.
	67	#:compression compression
	68	#:compression-level 3)))
	69
	70	;; Honor ~/.ssh/config.
	71	(session-parse-config! session)
	72
	73	(match (connect! session)
	74	('ok
	75	;; Use public key authentication, via the SSH agent if it's available.
	76	(match (userauth-public-key/auto! session)
	77	('success
	78	session)
	79	(x
	80	(disconnect! session)
	81	(raise (condition
	82	(&message
69daee23	83	(message (format #f (G_ "SSH authentication failed for '~a': ~a~%")
615c5298 LC	84	host (get-error session)))))))))
	85	(x
	86	;; Connection failed or timeout expired.
	87	(raise (condition
	88	(&message
69daee23	89	(message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
615c5298 LC	90	host (get-error session))))))))))
615c5298 LC	91
e5378337 LC	92	(define* (remote-daemon-channel session
	93	#:optional
	94	(socket-name
	95	"/var/guix/daemon-socket/socket"))
	96	"Return an input/output port (an SSH channel) to the daemon at SESSION."
987a29ba LC	97	(define redirect
	98	;; Code run in SESSION to redirect the remote process' stdin/stdout to the
	99	;; daemon's socket, à la socat. The SSH protocol supports forwarding to
	100	;; Unix-domain sockets but libssh doesn't have an API for that, hence this
	101	;; hack.
	102	`(begin
	103	(use-modules (ice-9 match) (rnrs io ports))
	104
	105	(let ((sock (socket AF_UNIX SOCK_STREAM 0))
	106	(stdin (current-input-port))
	107	(stdout (current-output-port)))
	108	(setvbuf stdin _IONBF)
	109	(setvbuf stdout _IONBF)
	110	(connect sock AF_UNIX ,socket-name)
	111
	112	(let loop ()
	113	(match (select (list stdin sock) '() (list stdin stdout sock))
	114	((reads writes ())
	115	(when (memq stdin reads)
	116	(match (get-bytevector-some stdin)
	117	((? eof-object?)
	118	(primitive-exit 0))
	119	(bv
	120	(put-bytevector sock bv))))
	121	(when (memq sock reads)
	122	(match (get-bytevector-some sock)
	123	((? eof-object?)
	124	(primitive-exit 0))
	125	(bv
	126	(put-bytevector stdout bv))))
	127	(loop))
	128	(_
	129	(primitive-exit 1)))))))
	130
e5378337 LC	131	(open-remote-pipe* session OPEN_BOTH
	132	;; Sort-of shell-quote REDIRECT.
	133	"guile" "-c"
	134	(object->string
	135	(object->string redirect))))
	136
	137	(define* (connect-to-remote-daemon session
	138	#:optional
	139	(socket-name
	140	"/var/guix/daemon-socket/socket"))
	141	"Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
	142	an SSH session. Return a <nix-server> object."
	143	(open-connection #:port (remote-daemon-channel session)))
	144
987a29ba LC	145
	146	(define (store-import-channel session)
	147	"Return an output port to which archives to be exported to SESSION's store
	148	can be written."
	149	;; Using the 'import-paths' RPC on a remote store would be slow because it
	150	;; makes a round trip every time 32 KiB have been transferred. This
	151	;; procedure instead opens a separate channel to use the remote
	152	;; 'import-paths' procedure, which consumes all the data in a single round
de9d8f0e LC	153	;; trip. This optimizes the successful case at the expense of error
	154	;; conditions: errors can only be reported once all the input has been
	155	;; consumed.
987a29ba LC	156	(define import
987a29ba LC	157	`(begin
de9d8f0e LC	158	(use-modules (guix) (srfi srfi-34)
de9d8f0e LC	159	(rnrs io ports) (rnrs bytevectors))
987a29ba	160
de9d8f0e LC	161	(define (consume-input port)
	162	(let ((bv (make-bytevector 32768)))
	163	(let loop ()
	164	(let ((n (get-bytevector-n! port bv 0
	165	(bytevector-length bv))))
	166	(unless (eof-object? n)
	167	(loop))))))
987a29ba	168
de9d8f0e LC	169	;; Upon completion, write an sexp that denotes the status.
	170	(write
	171	(catch #t
	172	(lambda ()
	173	(guard (c ((nix-protocol-error? c)
	174	;; Consume all the input since the only time we can
	175	;; report the error is after everything has been
	176	;; consumed.
	177	(consume-input (current-input-port))
	178	(list 'protocol-error (nix-protocol-error-message c))))
	179	(with-store store
	180	(setvbuf (current-input-port) _IONBF)
	181	(import-paths store (current-input-port))
	182	'(success))))
	183	(lambda args
	184	(cons 'error args))))))
987a29ba	185
de9d8f0e LC	186	(open-remote-pipe session
	187	(string-join
	188	`("guile" "-c"
	189	,(object->string (object->string import))))
	190	OPEN_BOTH))
987a29ba	191
e9629e82 LC	192	(define* (store-export-channel session files
e9629e82 LC	193	#:key recursive?)
987a29ba	194	"Return an input port from which an export of FILES from SESSION's store can
e9629e82	195	be read. When RECURSIVE? is true, the closure of FILES is exported."
987a29ba LC	196	;; Same as above: this is more efficient than calling 'export-paths' on a
	197	;; remote store.
	198	(define export
	199	`(begin
	200	(use-modules (guix))
	201
	202	(with-store store
	203	(setvbuf (current-output-port) _IONBF)
	204
	205	;; FIXME: Exceptions are silently swallowed. We should report them
	206	;; somehow.
e9629e82 LC	207	(export-paths store ',files (current-output-port)
e9629e82 LC	208	#:recursive? ,recursive?))))
987a29ba LC	209
	210	(open-remote-input-pipe session
	211	(string-join
	212	`("guile" "-c"
	213	,(object->string
	214	(object->string export))))))
	215
	216	(define* (send-files local files remote
e9629e82 LC	217	#:key
	218	recursive?
	219	(log-port (current-error-port)))
987a29ba	220	"Send the subset of FILES from LOCAL (a local store) that's missing to
23973e4f LC	221	REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES.
23973e4f LC	222	Return the list of store items actually sent."
987a29ba	223	;; Compute the subset of FILES missing on SESSION and send them.
e9629e82 LC	224	(let* ((files (if recursive? (requisites local files) files))
e9629e82 LC	225	(session (channel-get-session (nix-server-socket remote)))
987a29ba LC	226	(node (make-node session))
	227	(missing (node-eval node
	228	`(begin
	229	(use-modules (guix)
	230	(srfi srfi-1) (srfi srfi-26))
	231
	232	(with-store store
	233	(remove (cut valid-path? store <>)
	234	',files)))))
	235	(count (length missing))
	236	(port (store-import-channel session)))
	237	(format log-port (N_ "sending ~a store item to '~a'...~%"
	238	"sending ~a store items to '~a'...~%" count)
	239	count (session-get session 'host))
	240
	241	;; Send MISSING in topological order.
	242	(export-paths local missing port)
	243
	244	;; Tell the remote process that we're done. (In theory the end-of-archive
	245	;; mark of 'export-paths' would be enough, but in practice it's not.)
	246	(channel-send-eof port)
	247
de9d8f0e LC	248	;; Wait for completion of the remote process and read the status sexp from
	249	;; PORT.
	250	(let* ((result (false-if-exception (read port)))
	251	(status (zero? (channel-get-exit-status port))))
987a29ba	252	(close-port port)
de9d8f0e LC	253	(match result
	254	(('success . _)
	255	missing)
	256	(('protocol-error message)
	257	(raise (condition
	258	(&nix-protocol-error (message message) (status 42)))))
	259	(('error key args ...)
	260	(raise (condition
	261	(&nix-protocol-error
	262	(message (call-with-output-string
	263	(lambda (port)
	264	(print-exception port #f key args))))
	265	(status 43)))))
	266	(_
	267	(raise (condition
	268	(&nix-protocol-error
	269	(message "unknown error while sending files over SSH")
	270	(status 44)))))))))
987a29ba LC	271
	272	(define (remote-store-session remote)
	273	"Return the SSH channel beneath REMOTE, a remote store as returned by
	274	'connect-to-remote-daemon', or #f."
	275	(channel-get-session (nix-server-socket remote)))
	276
	277	(define (remote-store-host remote)
	278	"Return the name of the host REMOTE is connected to, where REMOTE is a
	279	remote store as returned by 'connect-to-remote-daemon'."
	280	(match (remote-store-session remote)
	281	(#f #f)
	282	((? session? session)
	283	(session-get session 'host))))
	284
e9629e82 LC	285	(define* (file-retrieval-port files remote
e9629e82 LC	286	#:key recursive?)
987a29ba LC	287	"Return an input port from which to retrieve FILES (a list of store items)
	288	from REMOTE, along with the number of items to retrieve (lower than or equal
	289	to the length of FILES.)"
e9629e82 LC	290	(values (store-export-channel (remote-store-session remote) files
	291	#:recursive? recursive?)
	292	(length files))) ;XXX: inaccurate when RECURSIVE? is true
987a29ba LC	293
987a29ba LC	294	(define* (retrieve-files local files remote
e9629e82	295	#:key recursive? (log-port (current-error-port)))
987a29ba	296	"Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on
e9629e82	297	LOCAL. When RECURSIVE? is true, retrieve the closure of FILES."
987a29ba	298	(let-values (((port count)
e9629e82 LC	299	(file-retrieval-port files remote
e9629e82 LC	300	#:recursive? recursive?)))
987a29ba LC	301	(format #t (N_ "retrieving ~a store item from '~a'...~%"
	302	"retrieving ~a store items from '~a'...~%" count)
	303	count (remote-store-host remote))
13164a21 LC	304	(when (eof-object? (lookahead-u8 port))
	305	;; The failure could be because one of the requested store items is not
	306	;; valid on REMOTE, or because Guile or Guix is improperly installed.
	307	;; TODO: Improve error reporting.
	308	(raise (condition
	309	(&message
	310	(message
	311	(format #f
69daee23	312	(G_ "failed to retrieve store items from '~a'")
13164a21	313	(remote-store-host remote)))))))
987a29ba LC	314
	315	(let ((result (import-paths local port)))
	316	(close-port port)
	317	result)))
	318
	319	;;; ssh.scm ends here