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