copy.scm 7.0 KB

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