guix/scripts/copy.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2019, 2020 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 scripts copy)
  20   #:use-module (guix ui)
  21   #:use-module (guix scripts)
  22   #:use-module (guix ssh)
  23   #:use-module ((ssh session) #:select (disconnect!))
  24   #:use-module (guix store)
  25   #:use-module ((guix status) #:select (with-status-verbosity))
  26   #:use-module (guix utils)
  27   #:use-module (guix derivations)
  28   #:use-module (guix scripts build)
  29   #:use-module ((guix scripts archive) #:select (options->derivations+files))
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (srfi srfi-37)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 format)
  35   #:export (guix-copy))
  36
  37 \f
  38 ;;;
  39 ;;; Exchanging store items over SSH.
  40 ;;;
  41
  42 (define (ssh-spec->user+host+port spec)
  43   "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return
  44 three values: the user name (or #f), the host name, and the TCP port
  45 number (or #f) corresponding to SPEC."
  46   (define tokens
  47     (char-set #\@ #\:))
  48
  49   (match (string-tokenize spec (char-set-complement tokens))
  50     ((host)
  51      (values #f host #f))
  52     ((left right)
  53      (if (string-index spec #\@)
  54          (values left right #f)
  55          (values #f left (string->number right))))
  56     ((user host port)
  57      (match (string->number port)
  58        ((? integer? port)
  59         (values user host port))
  60        (x
  61         (leave (G_ "~a: invalid TCP port number~%") port))))
  62     (x
  63      (leave (G_ "~a: invalid SSH specification~%") spec))))
  64
  65 (define (send-to-remote-host local target opts)
  66   "Send ITEMS to TARGET.  ITEMS is a list of store items or package names; for ;
  67 package names, build the underlying packages before sending them."
  68   (let-values (((user host port)
  69                 (ssh-spec->user+host+port target))
  70                ((drv items)
  71                 (options->derivations+files local opts)))
  72     (and (build-derivations local drv)
  73          (let* ((session (open-ssh-session host #:user user
  74                                            #:port (or port 22)))
  75                 (remote  (connect-to-remote-daemon session))
  76                 (sent    (send-files local items remote
  77                                      #:recursive? #t)))
  78            (close-connection remote)
  79            (format #t "~{~a~%~}" sent)
  80            sent))))
  81
  82 (define (retrieve-from-remote-host local source opts)
  83   "Retrieve ITEMS from SOURCE."
  84   (let*-values (((user host port)
  85                  (ssh-spec->user+host+port source))
  86                 ((session)
  87                  (open-ssh-session host #:user user #:port (or port 22)))
  88                 ((remote)
  89                  (connect-to-remote-daemon session)))
  90     ;; TODO: Here we could to compute and build the derivations on REMOTE
  91     ;; rather than on LOCAL (one-off offloading) but that is currently too
  92     ;; slow due to the many RPC round trips.  So we just assume that REMOTE
  93     ;; contains ITEMS.
  94     (let*-values (((drv items)
  95                    (options->derivations+files local opts))
  96                   ((retrieved)
  97                    (retrieve-files local items remote #:recursive? #t)))
  98       (close-connection remote)
  99       (disconnect! session)
 100       (format #t "~{~a~%~}" retrieved)
 101       retrieved)))
 102
 103 \f
 104 ;;;
 105 ;;; Options.
 106 ;;;
 107
 108 (define (show-help)
 109   (display (G_ "Usage: guix copy [OPTION]... ITEMS...
 110 Copy ITEMS to or from the specified host over SSH.\n"))
 111   (display (G_ "
 112       --to=HOST          send ITEMS to HOST"))
 113   (display (G_ "
 114       --from=HOST        receive ITEMS from HOST"))
 115   (display (G_ "
 116   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 117   (newline)
 118   (show-build-options-help)
 119   (newline)
 120   (display (G_ "
 121   -h, --help             display this help and exit"))
 122   (display (G_ "
 123   -V, --version          display version information and exit"))
 124   (newline)
 125   (show-bug-report-information))
 126
 127 (define %options
 128   ;; Specifications of the command-line options.
 129   (cons* (option '("to") #t #f
 130                  (lambda (opt name arg result)
 131                    (alist-cons 'destination arg result)))
 132          (option '("from") #t #f
 133                  (lambda (opt name arg result)
 134                    (alist-cons 'source arg result)))
 135          (option '(#\v "verbosity") #t #f
 136                  (lambda (opt name arg result)
 137                    (let ((level (string->number* arg)))
 138                      (alist-cons 'verbosity level
 139                                  (alist-delete 'verbosity result)))))
 140          (option '(#\n "dry-run") #f #f
 141                  (lambda (opt name arg result)
 142                    (alist-cons 'dry-run? #t result)))
 143
 144          (option '(#\h "help") #f #f
 145                  (lambda args
 146                    (show-help)
 147                    (exit 0)))
 148          (option '(#\V "version") #f #f
 149                  (lambda args
 150                    (show-version-and-exit "guix copy")))
 151          (option '(#\s "system") #t #f
 152                  (lambda (opt name arg result)
 153                    (alist-cons 'system arg
 154                                (alist-delete 'system result eq?))))
 155          %standard-build-options))
 156
 157 (define %default-options
 158   `((system . ,(%current-system))
 159     (substitutes? . #t)
 160     (offload? . #t)
 161     (graft? . #t)
 162     (print-build-trace? . #t)
 163     (print-extended-build-trace? . #t)
 164     (multiplexed-build-output? . #t)
 165     (debug . 0)
 166     (verbosity . 2)))
 167
 168 \f
 169 ;;;
 170 ;;; Entry point.
 171 ;;;
 172
 173 (define-command (guix-copy . args)
 174   (category plumbing)
 175   (synopsis "copy store items remotely over SSH")
 176
 177   (with-error-handling
 178     (let* ((opts     (parse-command-line args %options (list %default-options)))
 179            (source   (assoc-ref opts 'source))
 180            (target   (assoc-ref opts 'destination)))
 181       (with-store store
 182         (set-build-options-from-command-line store opts)
 183         (with-build-handler (build-notifier #:use-substitutes?
 184                                             (assoc-ref opts 'substitutes?)
 185                                             #:verbosity
 186                                             (assoc-ref opts 'verbosity)
 187                                             #:dry-run?
 188                                             (assoc-ref opts 'dry-run?))
 189           (with-status-verbosity (assoc-ref opts 'verbosity)
 190             (cond (target (send-to-remote-host store target opts))
 191                   (source (retrieve-from-remote-host store source opts))
 192                   (else   (leave (G_ "use '--to' or '--from'~%"))))))))))