123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2016, 2017, 2019, 2020, 2021 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 scripts copy)
- #:use-module (guix ui)
- #:use-module (guix scripts)
- #:use-module (guix ssh)
- #:use-module ((ssh session) #:select (disconnect!))
- #:use-module (guix store)
- #:use-module ((guix status) #:select (with-status-verbosity))
- #:use-module (guix utils)
- #:use-module (guix derivations)
- #:use-module (guix scripts build)
- #:use-module ((guix scripts archive) #:select (options->derivations+files))
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-37)
- #:use-module (ice-9 match)
- #:use-module (ice-9 format)
- #:export (guix-copy))
- ;;;
- ;;; Exchanging store items over SSH.
- ;;;
- (define (ssh-spec->user+host+port spec)
- "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return
- three values: the user name (or #f), the host name, and the TCP port
- number (or #f) corresponding to SPEC."
- (define tokens
- (char-set #\@ #\:))
- (match (string-tokenize spec (char-set-complement tokens))
- ((host)
- (values #f host #f))
- ((left right)
- (if (string-index spec #\@)
- (values left right #f)
- (values #f left (string->number right))))
- ((user host port)
- (match (string->number port)
- ((? integer? port)
- (values user host port))
- (x
- (leave (G_ "~a: invalid TCP port number~%") port))))
- (x
- (leave (G_ "~a: invalid SSH specification~%") spec))))
- (define (send-to-remote-host local target opts)
- "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ;
- package names, build the underlying packages before sending them."
- (let-values (((user host port)
- (ssh-spec->user+host+port target))
- ((drv items)
- (options->derivations+files local opts)))
- (and (build-derivations local drv)
- (let* ((session (open-ssh-session host #:user user
- #:port (or port 22)))
- (remote (connect-to-remote-daemon session))
- (sent (send-files local items remote
- #:recursive? #t)))
- (close-connection remote)
- (format #t "~{~a~%~}" sent)
- sent))))
- (define (retrieve-from-remote-host local source opts)
- "Retrieve ITEMS from SOURCE."
- (let*-values (((user host port)
- (ssh-spec->user+host+port source))
- ((session)
- (open-ssh-session host #:user user #:port (or port 22)))
- ((remote)
- (connect-to-remote-daemon session)))
- ;; TODO: Here we could to compute and build the derivations on REMOTE
- ;; rather than on LOCAL (one-off offloading) but that is currently too
- ;; slow due to the many RPC round trips. So we just assume that REMOTE
- ;; contains ITEMS.
- (let*-values (((drv items)
- (options->derivations+files local opts))
- ((retrieved)
- (retrieve-files local items remote #:recursive? #t)))
- (close-connection remote)
- (disconnect! session)
- (format #t "~{~a~%~}" retrieved)
- retrieved)))
- ;;;
- ;;; Options.
- ;;;
- (define (show-help)
- (display (G_ "Usage: guix copy [OPTION]... ITEMS...
- Copy ITEMS to or from the specified host over SSH.\n"))
- (display (G_ "
- --to=HOST send ITEMS to HOST"))
- (display (G_ "
- --from=HOST receive ITEMS from HOST"))
- (display (G_ "
- -v, --verbosity=LEVEL use the given verbosity LEVEL"))
- (newline)
- (show-build-options-help)
- (newline)
- (display (G_ "
- -h, --help display this help and exit"))
- (display (G_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
- (define %options
- ;; Specifications of the command-line options.
- (cons* (option '("to") #t #f
- (lambda (opt name arg result)
- (alist-cons 'destination arg result)))
- (option '("from") #t #f
- (lambda (opt name arg result)
- (alist-cons 'source arg result)))
- (option '(#\v "verbosity") #t #f
- (lambda (opt name arg result)
- (let ((level (string->number* arg)))
- (alist-cons 'verbosity level
- (alist-delete 'verbosity result)))))
- (option '(#\n "dry-run") #f #f
- (lambda (opt name arg result)
- (alist-cons 'dry-run? #t result)))
- (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix copy")))
- (option '(#\s "system") #t #f
- (lambda (opt name arg result)
- (alist-cons 'system arg
- (alist-delete 'system result eq?))))
- %standard-build-options))
- (define %default-options
- `((system . ,(%current-system))
- (substitutes? . #t)
- (offload? . #t)
- (graft? . #t)
- (print-build-trace? . #t)
- (print-extended-build-trace? . #t)
- (multiplexed-build-output? . #t)
- (debug . 0)
- (verbosity . 3)))
- ;;;
- ;;; Entry point.
- ;;;
- (define-command (guix-copy . args)
- (category plumbing)
- (synopsis "copy store items remotely over SSH")
- (with-error-handling
- (let* ((opts (parse-command-line args %options (list %default-options)))
- (source (assoc-ref opts 'source))
- (target (assoc-ref opts 'destination)))
- (with-store store
- (set-build-options-from-command-line store opts)
- (with-build-handler (build-notifier #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:verbosity
- (assoc-ref opts 'verbosity)
- #:dry-run?
- (assoc-ref opts 'dry-run?))
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (cond (target (send-to-remote-host store target opts))
- (source (retrieve-from-remote-host store source opts))
- (else (leave (G_ "use '--to' or '--from'~%"))))))))))
|