208 lines
7.3 KiB
Scheme
208 lines
7.3 KiB
Scheme
|
;;; GNU Guix --- Functional package management for GNU
|
|||
|
|
;;; Copyright © 2016 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 (guix store)
|
|||
|
|
#:use-module (guix utils)
|
|||
|
|
#:use-module (guix derivations)
|
|||
|
|
#:use-module (guix scripts build)
|
|||
|
|
#:use-module ((guix scripts archive) #:select (options->derivations+files))
|
|||
|
|
#:use-module (ssh session)
|
|||
|
|
#:use-module (ssh auth)
|
|||
|
|
#:use-module (ssh key)
|
|||
|
|
#: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 %compression
|
|||
|
|
"zlib@openssh.com,zlib")
|
|||
|
|
|
|||
|
|
(define* (open-ssh-session host #:key user port)
|
|||
|
|
"Open an SSH session for HOST and return it. When USER and PORT are #f, use
|
|||
|
|
default values or whatever '~/.ssh/config' specifies; otherwise use them.
|
|||
|
|
Throw an error on failure."
|
|||
|
|
(let ((session (make-session #:user user
|
|||
|
|
#:host host
|
|||
|
|
#:port port
|
|||
|
|
#:timeout 10 ;seconds
|
|||
|
|
;; #:log-verbosity 'protocol
|
|||
|
|
|
|||
|
|
;; We need lightweight compression when
|
|||
|
|
;; exchanging full archives.
|
|||
|
|
#:compression %compression
|
|||
|
|
#:compression-level 3)))
|
|||
|
|
|
|||
|
|
;; Honor ~/.ssh/config.
|
|||
|
|
(session-parse-config! session)
|
|||
|
|
|
|||
|
|
(match (connect! session)
|
|||
|
|
('ok
|
|||
|
|
;; Let the SSH agent authenticate us to the server.
|
|||
|
|
(match (userauth-agent! session)
|
|||
|
|
('success
|
|||
|
|
session)
|
|||
|
|
(x
|
|||
|
|
(disconnect! session)
|
|||
|
|
(leave (_ "SSH authentication failed for '~a': ~a~%")
|
|||
|
|
host (get-error session)))))
|
|||
|
|
(x
|
|||
|
|
;; Connection failed or timeout expired.
|
|||
|
|
(leave (_ "SSH connection to '~a' failed: ~a~%")
|
|||
|
|
host (get-error session))))))
|
|||
|
|
|
|||
|
|
(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 (_ "~a: invalid TCP port number~%") port))))
|
|||
|
|
(x
|
|||
|
|
(leave (_ "~a: invalid SSH specification~%") spec))))
|
|||
|
|
|
|||
|
|
(define (send-to-remote-host 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."
|
|||
|
|
(with-store local
|
|||
|
|
(set-build-options-from-command-line local opts)
|
|||
|
|
(let-values (((user host port)
|
|||
|
|
(ssh-spec->user+host+port target))
|
|||
|
|
((drv items)
|
|||
|
|
(options->derivations+files local opts)))
|
|||
|
|
(show-what-to-build local drv
|
|||
|
|
#:use-substitutes? (assoc-ref opts 'substitutes?)
|
|||
|
|
#:dry-run? (assoc-ref opts 'dry-run?))
|
|||
|
|
|
|||
|
|
(and (or (assoc-ref opts 'dry-run?)
|
|||
|
|
(build-derivations local drv))
|
|||
|
|
(let* ((session (open-ssh-session host #:user user #:port port))
|
|||
|
|
(sent (send-files local items
|
|||
|
|
(connect-to-remote-daemon session)
|
|||
|
|
#:recursive? #t)))
|
|||
|
|
(format #t "~{~a~%~}" sent)
|
|||
|
|
sent)))))
|
|||
|
|
|
|||
|
|
(define (retrieve-from-remote-host source opts)
|
|||
|
|
"Retrieve ITEMS from SOURCE."
|
|||
|
|
(with-store local
|
|||
|
|
(let*-values (((user host port)
|
|||
|
|
(ssh-spec->user+host+port source))
|
|||
|
|
((session)
|
|||
|
|
(open-ssh-session host #:user user #:port port))
|
|||
|
|
((remote)
|
|||
|
|
(connect-to-remote-daemon session)))
|
|||
|
|
(set-build-options-from-command-line local opts)
|
|||
|
|
;; 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)))
|
|||
|
|
(format #t "~{~a~%~}" retrieved)
|
|||
|
|
retrieved))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
;;; Options.
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
(define (show-help)
|
|||
|
|
(display (_ "Usage: guix copy [OPTION]... ITEMS...
|
|||
|
|
Copy ITEMS to or from the specified host over SSH.\n"))
|
|||
|
|
(display (_ "
|
|||
|
|
--to=HOST send ITEMS to HOST"))
|
|||
|
|
(display (_ "
|
|||
|
|
--from=HOST receive ITEMS from HOST"))
|
|||
|
|
(newline)
|
|||
|
|
(show-build-options-help)
|
|||
|
|
(newline)
|
|||
|
|
(display (_ "
|
|||
|
|
-h, --help display this help and exit"))
|
|||
|
|
(display (_ "
|
|||
|
|
-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 '(#\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)
|
|||
|
|
(graft? . #t)
|
|||
|
|
(max-silent-time . 3600)
|
|||
|
|
(verbosity . 0)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
;;; Entry point.
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
(define (guix-copy . args)
|
|||
|
|
(with-error-handling
|
|||
|
|
(let* ((opts (parse-command-line args %options (list %default-options)))
|
|||
|
|
(source (assoc-ref opts 'source))
|
|||
|
|
(target (assoc-ref opts 'destination)))
|
|||
|
|
(cond (target (send-to-remote-host target opts))
|
|||
|
|
(source (retrieve-from-remote-host source opts))
|
|||
|
|
(else (leave (_ "use '--to' or '--from'~%")))))))
|