guix/ssh.scm

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