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