;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ludovic Courtès ;;; ;;; 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 . (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 ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! 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'~%")))))))