guix/scripts/copy.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 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 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 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   (with-store local
  68     (set-build-options-from-command-line local opts)
  69     (let-values (((user host port)
  70                   (ssh-spec->user+host+port target))
  71                  ((drv items)
  72                   (options->derivations+files local opts)))
  73       (show-what-to-build local drv
  74                           #:use-substitutes? (assoc-ref opts 'substitutes?)
  75                           #:dry-run? (assoc-ref opts 'dry-run?))
  76
  77       (and (or (assoc-ref opts 'dry-run?)
  78                (build-derivations local drv))
  79            (let* ((session (open-ssh-session host #:user user
  80                                              #:port (or port 22)))
  81                   (sent    (send-files local items
  82                                        (connect-to-remote-daemon session)
  83                                        #:recursive? #t)))
  84              (format #t "~{~a~%~}" sent)
  85              sent)))))
  86
  87 (define (retrieve-from-remote-host source opts)
  88   "Retrieve ITEMS from SOURCE."
  89   (with-store local
  90     (let*-values (((user host port)
  91                    (ssh-spec->user+host+port source))
  92                   ((session)
  93                    (open-ssh-session host #:user user #:port (or port 22)))
  94                   ((remote)
  95                    (connect-to-remote-daemon session)))
  96       (set-build-options-from-command-line local opts)
  97       ;; TODO: Here we could to compute and build the derivations on REMOTE
  98       ;; rather than on LOCAL (one-off offloading) but that is currently too
  99       ;; slow due to the many RPC round trips.  So we just assume that REMOTE
 100       ;; contains ITEMS.
 101       (let*-values (((drv items)
 102                      (options->derivations+files local opts))
 103                     ((retrieved)
 104                      (retrieve-files local items remote #:recursive? #t)))
 105         (format #t "~{~a~%~}" retrieved)
 106         retrieved))))
 107
 108 \f
 109 ;;;
 110 ;;; Options.
 111 ;;;
 112
 113 (define (show-help)
 114   (display (G_ "Usage: guix copy [OPTION]... ITEMS...
 115 Copy ITEMS to or from the specified host over SSH.\n"))
 116   (display (G_ "
 117       --to=HOST          send ITEMS to HOST"))
 118   (display (G_ "
 119       --from=HOST        receive ITEMS from HOST"))
 120   (display (G_ "
 121   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 122   (newline)
 123   (show-build-options-help)
 124   (newline)
 125   (display (G_ "
 126   -h, --help             display this help and exit"))
 127   (display (G_ "
 128   -V, --version          display version information and exit"))
 129   (newline)
 130   (show-bug-report-information))
 131
 132 (define %options
 133   ;; Specifications of the command-line options.
 134   (cons* (option '("to") #t #f
 135                  (lambda (opt name arg result)
 136                    (alist-cons 'destination arg result)))
 137          (option '("from") #t #f
 138                  (lambda (opt name arg result)
 139                    (alist-cons 'source arg result)))
 140          (option '(#\v "verbosity") #t #f
 141                  (lambda (opt name arg result)
 142                    (let ((level (string->number* arg)))
 143                      (alist-cons 'verbosity level
 144                                  (alist-delete 'verbosity result)))))
 145          (option '(#\h "help") #f #f
 146                  (lambda args
 147                    (show-help)
 148                    (exit 0)))
 149          (option '(#\V "version") #f #f
 150                  (lambda args
 151                    (show-version-and-exit "guix copy")))
 152          (option '(#\s "system") #t #f
 153                  (lambda (opt name arg result)
 154                    (alist-cons 'system arg
 155                                (alist-delete 'system result eq?))))
 156          %standard-build-options))
 157
 158 (define %default-options
 159   `((system . ,(%current-system))
 160     (substitutes? . #t)
 161     (build-hook? . #t)
 162     (graft? . #t)
 163     (print-build-trace? . #t)
 164     (print-extended-build-trace? . #t)
 165     (multiplexed-build-output? . #t)
 166     (debug . 0)
 167     (verbosity . 2)))
 168
 169 \f
 170 ;;;
 171 ;;; Entry point.
 172 ;;;
 173
 174 (define (guix-copy . args)
 175   (with-error-handling
 176     (let* ((opts     (parse-command-line args %options (list %default-options)))
 177            (source   (assoc-ref opts 'source))
 178            (target   (assoc-ref opts 'destination)))
 179       (with-status-verbosity (assoc-ref opts 'verbosity)
 180         (cond (target (send-to-remote-host target opts))
 181               (source (retrieve-from-remote-host source opts))
 182               (else   (leave (G_ "use '--to' or '--from'~%"))))))))