Não pode escolher mais do que 25 tópicos Os tópicos devem começar com uma letra ou um número, podem incluir traços ('-') e podem ter até 35 caracteres.
 
 
 
 
 
 

816 linhas
33 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix scripts pull)
  20. #:use-module (guix ui)
  21. #:use-module (guix colors)
  22. #:use-module (guix utils)
  23. #:use-module ((guix status) #:select (with-status-verbosity))
  24. #:use-module (guix scripts)
  25. #:use-module (guix store)
  26. #:use-module (guix config)
  27. #:use-module (guix packages)
  28. #:use-module (guix derivations)
  29. #:use-module (guix profiles)
  30. #:use-module (guix gexp)
  31. #:use-module (guix grafts)
  32. #:use-module (guix memoization)
  33. #:use-module (guix monads)
  34. #:use-module (guix channels)
  35. #:autoload (guix inferior) (open-inferior)
  36. #:use-module (guix scripts build)
  37. #:autoload (guix build utils) (which)
  38. #:use-module (guix git)
  39. #:use-module (git)
  40. #:use-module (gnu packages)
  41. #:use-module ((guix scripts package) #:select (build-and-use-profile
  42. delete-matching-generations))
  43. #:use-module ((gnu packages base) #:select (canonical-package))
  44. #:use-module (gnu packages guile)
  45. #:use-module ((gnu packages bootstrap)
  46. #:select (%bootstrap-guile))
  47. #:use-module ((gnu packages certs) #:select (le-certs))
  48. #:use-module (srfi srfi-1)
  49. #:use-module (srfi srfi-11)
  50. #:use-module (srfi srfi-26)
  51. #:use-module (srfi srfi-34)
  52. #:use-module (srfi srfi-35)
  53. #:use-module (srfi srfi-37)
  54. #:use-module (ice-9 match)
  55. #:use-module (ice-9 vlist)
  56. #:use-module (ice-9 format)
  57. #:export (display-profile-content
  58. guix-pull))
  59. ;;;
  60. ;;; Command-line options.
  61. ;;;
  62. (define %default-options
  63. ;; Alist of default option values.
  64. `((system . ,(%current-system))
  65. (substitutes? . #t)
  66. (build-hook? . #t)
  67. (print-build-trace? . #t)
  68. (print-extended-build-trace? . #t)
  69. (multiplexed-build-output? . #t)
  70. (graft? . #t)
  71. (debug . 0)
  72. (verbosity . 1)))
  73. (define (show-help)
  74. (display (G_ "Usage: guix pull [OPTION]...
  75. Download and deploy the latest version of Guix.\n"))
  76. (display (G_ "
  77. --verbose produce verbose output"))
  78. (display (G_ "
  79. -C, --channels=FILE deploy the channels defined in FILE"))
  80. (display (G_ "
  81. --url=URL download from the Git repository at URL"))
  82. (display (G_ "
  83. --commit=COMMIT download the specified COMMIT"))
  84. (display (G_ "
  85. --branch=BRANCH download the tip of the specified BRANCH"))
  86. (display (G_ "
  87. -N, --news display news compared to the previous generation"))
  88. (display (G_ "
  89. -l, --list-generations[=PATTERN]
  90. list generations matching PATTERN"))
  91. (display (G_ "
  92. --roll-back roll back to the previous generation"))
  93. (display (G_ "
  94. -d, --delete-generations[=PATTERN]
  95. delete generations matching PATTERN"))
  96. (display (G_ "
  97. -S, --switch-generation=PATTERN
  98. switch to a generation matching PATTERN"))
  99. (display (G_ "
  100. -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current"))
  101. (display (G_ "
  102. -v, --verbosity=LEVEL use the given verbosity LEVEL"))
  103. (display (G_ "
  104. -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
  105. (display (G_ "
  106. --bootstrap use the bootstrap Guile to build the new Guix"))
  107. (newline)
  108. (show-build-options-help)
  109. (display (G_ "
  110. -h, --help display this help and exit"))
  111. (display (G_ "
  112. -V, --version display version information and exit"))
  113. (newline)
  114. (show-bug-report-information))
  115. (define %options
  116. ;; Specifications of the command-line options.
  117. (cons* (option '("verbose") #f #f
  118. (lambda (opt name arg result)
  119. (alist-cons 'verbose? #t result)))
  120. (option '(#\C "channels") #t #f
  121. (lambda (opt name arg result)
  122. (alist-cons 'channel-file arg result)))
  123. (option '(#\l "list-generations") #f #t
  124. (lambda (opt name arg result)
  125. (cons `(query list-generations ,arg)
  126. result)))
  127. (option '("roll-back") #f #f
  128. (lambda (opt name arg result)
  129. (cons '(generation roll-back)
  130. result)))
  131. (option '(#\S "switch-generation") #t #f
  132. (lambda (opt name arg result)
  133. (cons `(generation switch ,arg)
  134. result)))
  135. (option '(#\d "delete-generations") #f #t
  136. (lambda (opt name arg result)
  137. (cons `(generation delete ,arg)
  138. result)))
  139. (option '(#\N "news") #f #f
  140. (lambda (opt name arg result)
  141. (cons '(query display-news) result)))
  142. (option '("url") #t #f
  143. (lambda (opt name arg result)
  144. (alist-cons 'repository-url arg
  145. (alist-delete 'repository-url result))))
  146. (option '("commit") #t #f
  147. (lambda (opt name arg result)
  148. (alist-cons 'ref `(commit . ,arg) result)))
  149. (option '("branch") #t #f
  150. (lambda (opt name arg result)
  151. (alist-cons 'ref `(branch . ,arg) result)))
  152. (option '(#\p "profile") #t #f
  153. (lambda (opt name arg result)
  154. (alist-cons 'profile (canonicalize-profile arg)
  155. result)))
  156. (option '(#\s "system") #t #f
  157. (lambda (opt name arg result)
  158. (alist-cons 'system arg
  159. (alist-delete 'system result eq?))))
  160. (option '(#\n "dry-run") #f #f
  161. (lambda (opt name arg result)
  162. (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
  163. (option '(#\v "verbosity") #t #f
  164. (lambda (opt name arg result)
  165. (let ((level (string->number* arg)))
  166. (alist-cons 'verbosity level
  167. (alist-delete 'verbosity result)))))
  168. (option '("bootstrap") #f #f
  169. (lambda (opt name arg result)
  170. (alist-cons 'bootstrap? #t result)))
  171. (option '(#\h "help") #f #f
  172. (lambda args
  173. (show-help)
  174. (exit 0)))
  175. (option '(#\V "version") #f #f
  176. (lambda args
  177. (show-version-and-exit "guix pull")))
  178. %standard-build-options))
  179. (define* (display-profile-news profile #:key concise?
  180. current-is-newer?)
  181. "Display what's up in PROFILE--new packages, and all that. If
  182. CURRENT-IS-NEWER? is true, assume that the current process represents the
  183. newest generation of PROFILE. Return true when there's more info to display."
  184. (match (memv (generation-number profile)
  185. (reverse (profile-generations profile)))
  186. ((current previous _ ...)
  187. (let ((these (fold-available-packages
  188. (lambda* (name version result
  189. #:key supported? deprecated?
  190. #:allow-other-keys)
  191. (if (and supported? (not deprecated?))
  192. (alist-cons name version result)
  193. result))
  194. '()))
  195. (those (profile-package-alist
  196. (generation-file-name profile
  197. (if current-is-newer?
  198. previous
  199. current)))))
  200. (let ((old (if current-is-newer? those these))
  201. (new (if current-is-newer? these those)))
  202. (display-new/upgraded-packages old new
  203. #:concise? concise?
  204. #:heading
  205. (G_ "New in this revision:\n")))))
  206. (_ #f)))
  207. (define (display-channel channel)
  208. "Display information about CHANNEL."
  209. (format (current-error-port)
  210. ;; TRANSLATORS: This describes a "channel"; the first placeholder is
  211. ;; the channel name (e.g., "guix") and the second placeholder is its
  212. ;; URL.
  213. (G_ " ~a at ~a~%")
  214. (channel-name channel)
  215. (channel-url channel)))
  216. (define (channel=? channel1 channel2)
  217. "Return true if CHANNEL1 and CHANNEL2 are the same for all practical
  218. purposes."
  219. ;; Assume that the URL matters less than the name.
  220. (eq? (channel-name channel1) (channel-name channel2)))
  221. (define (display-news-entry-title entry language port)
  222. "Display the title of ENTRY, a news entry, to PORT."
  223. (define title
  224. (channel-news-entry-title entry))
  225. (format port " ~a~%"
  226. (highlight
  227. (string-trim-right
  228. (texi->plain-text (or (assoc-ref title language)
  229. (assoc-ref title (%default-message-language))
  230. ""))))))
  231. (define (display-news-entry entry language port)
  232. "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to
  233. PORT."
  234. (define body
  235. (channel-news-entry-body entry))
  236. (display-news-entry-title entry language port)
  237. (format port (G_ " commit ~a~%")
  238. (channel-news-entry-commit entry))
  239. (newline port)
  240. (format port " ~a~%"
  241. (indented-string
  242. (parameterize ((%text-width (- (%text-width) 4)))
  243. (string-trim-right
  244. (texi->plain-text (or (assoc-ref body language)
  245. (assoc-ref body (%default-message-language))
  246. ""))))
  247. 4)))
  248. (define* (display-channel-specific-news new old
  249. #:key (port (current-output-port))
  250. concise?)
  251. "Display channel news applicable the commits between OLD and NEW, where OLD
  252. and NEW are <channel> records with a proper 'commit' field. When CONCISE? is
  253. true, display nothing but the news titles. Return true if there are more news
  254. to display."
  255. (let ((channel new)
  256. (old (channel-commit old))
  257. (new (channel-commit new)))
  258. (when (and old new)
  259. (let ((language (current-message-language)))
  260. (match (channel-news-for-commit channel new old)
  261. (() ;no news is good news
  262. #f)
  263. ((entries ...)
  264. (newline port)
  265. (format port (G_ "News for channel '~a'~%")
  266. (channel-name channel))
  267. (for-each (if concise?
  268. (cut display-news-entry-title <> language port)
  269. (cut display-news-entry <> language port))
  270. entries)
  271. (newline port)
  272. #t))))))
  273. (define* (display-channel-news profile
  274. #:optional
  275. (previous
  276. (and=> (relative-generation profile -1)
  277. (cut generation-file-name profile <>))))
  278. "Display news about the channels of PROFILE compared to PREVIOUS."
  279. (when previous
  280. (let ((old-channels (profile-channels previous))
  281. (new-channels (profile-channels profile)))
  282. (and (pair? old-channels) (pair? new-channels)
  283. (begin
  284. (match (lset-difference channel=? new-channels old-channels)
  285. (()
  286. #t)
  287. (new
  288. (let ((count (length new)))
  289. (format (current-error-port)
  290. (N_ " ~*One new channel:~%"
  291. " ~a new channels:~%" count)
  292. count)
  293. (for-each display-channel new))))
  294. (match (lset-difference channel=? old-channels new-channels)
  295. (()
  296. #t)
  297. (removed
  298. (let ((count (length removed)))
  299. (format (current-error-port)
  300. (N_ " ~*One channel removed:~%"
  301. " ~a channels removed:~%" count)
  302. count)
  303. (for-each display-channel removed))))
  304. ;; Display channel-specific news for those channels that were
  305. ;; here before and are still around afterwards.
  306. (for-each (match-lambda
  307. ((new old)
  308. (display-channel-specific-news new old)))
  309. (filter-map (lambda (new)
  310. (define old
  311. (find (cut channel=? new <>)
  312. old-channels))
  313. (and old (list new old)))
  314. new-channels)))))))
  315. (define* (display-channel-news-headlines profile)
  316. "Display the titles of news about the channels of PROFILE compared to its
  317. previous generation. Return true if there are news to display."
  318. (define previous
  319. (and=> (relative-generation profile -1)
  320. (cut generation-file-name profile <>)))
  321. (when previous
  322. (let ((old-channels (profile-channels previous))
  323. (new-channels (profile-channels profile)))
  324. ;; Find the channels present in both PROFILE and PREVIOUS, and print
  325. ;; their news.
  326. (and (pair? old-channels) (pair? new-channels)
  327. (let ((channels (filter-map (lambda (new)
  328. (define old
  329. (find (cut channel=? new <>)
  330. old-channels))
  331. (and old (list new old)))
  332. new-channels)))
  333. (define more?
  334. (map (match-lambda
  335. ((new old)
  336. (display-channel-specific-news new old
  337. #:concise? #t)))
  338. channels))
  339. (any ->bool more?))))))
  340. (define (display-news profile)
  341. ;; Display profile news, with the understanding that this process represents
  342. ;; the newest generation.
  343. (display-profile-news profile
  344. #:current-is-newer? #t)
  345. (display-channel-news profile))
  346. (define* (build-and-install instances profile
  347. #:key use-substitutes? verbose? dry-run?)
  348. "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is
  349. true, display what would be built without actually building it."
  350. (define update-profile
  351. (store-lift build-and-use-profile))
  352. (define guix-command
  353. ;; The 'guix' command before we've built the new profile.
  354. (which "guix"))
  355. (mlet %store-monad ((manifest (channel-instances->manifest instances)))
  356. (mbegin %store-monad
  357. (update-profile profile manifest
  358. #:use-substitutes? use-substitutes?
  359. #:hooks %channel-profile-hooks
  360. #:dry-run? dry-run?)
  361. (munless dry-run?
  362. (return (newline))
  363. (return
  364. (let ((more? (list (display-profile-news profile #:concise? #t)
  365. (display-channel-news-headlines profile))))
  366. (when (any ->bool more?)
  367. (display-hint
  368. (G_ "Run @command{guix pull --news} to read all the news.")))))
  369. (if guix-command
  370. (let ((new (map (cut string-append <> "/bin/guix")
  371. (list (user-friendly-profile profile)
  372. profile))))
  373. ;; Is the 'guix' command previously in $PATH the same as the new
  374. ;; one? If the answer is "no", then suggest 'hash guix'.
  375. (unless (member guix-command new)
  376. (display-hint (format #f (G_ "After setting @code{PATH}, run
  377. @command{hash guix} to make sure your shell refers to @file{~a}.")
  378. (first new))))
  379. (return #f))
  380. (return #f))))))
  381. (define (honor-lets-encrypt-certificates! store)
  382. "Tell Guile-Git to use the Let's Encrypt certificates."
  383. (let* ((drv (package-derivation store le-certs))
  384. (certs (string-append (derivation->output-path drv)
  385. "/etc/ssl/certs")))
  386. (build-derivations store (list drv))
  387. (set-tls-certificate-locations! certs)))
  388. (define (honor-x509-certificates store)
  389. "Use the right X.509 certificates for Git checkouts over HTTPS."
  390. (unless (honor-system-x509-certificates!)
  391. (honor-lets-encrypt-certificates! store)))
  392. (define (report-git-error error)
  393. "Report the given Guile-Git error."
  394. ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
  395. ;; errors would be represented by integers.
  396. (match error
  397. ((? integer? error) ;old Guile-Git
  398. (leave (G_ "Git error ~a~%") error))
  399. ((? git-error? error) ;new Guile-Git
  400. (leave (G_ "Git error: ~a~%") (git-error-message error)))))
  401. (define-syntax-rule (with-git-error-handling body ...)
  402. (catch 'git-error
  403. (lambda ()
  404. body ...)
  405. (lambda (key err)
  406. (report-git-error err))))
  407. ;;;
  408. ;;; Profile.
  409. ;;;
  410. (define %current-profile
  411. ;; The "real" profile under /var/guix.
  412. (string-append %profile-directory "/current-guix"))
  413. (define %user-profile-directory
  414. ;; The user-friendly name of %CURRENT-PROFILE.
  415. (string-append (config-directory #:ensure? #f) "/current"))
  416. (define (migrate-generations profile directory)
  417. "Migrate the generations of PROFILE to DIRECTORY."
  418. (format (current-error-port)
  419. (G_ "Migrating profile generations to '~a'...~%")
  420. %profile-directory)
  421. (let ((current (generation-number profile)))
  422. (for-each (lambda (generation)
  423. (let ((source (generation-file-name profile generation))
  424. (target (string-append directory "/current-guix-"
  425. (number->string generation)
  426. "-link")))
  427. ;; Note: Don't use 'rename-file' as SOURCE and TARGET might
  428. ;; live on different file systems.
  429. (symlink (readlink source) target)
  430. (delete-file source)))
  431. (profile-generations profile))
  432. (symlink (string-append "current-guix-"
  433. (number->string current) "-link")
  434. (string-append directory "/current-guix"))))
  435. (define (ensure-default-profile)
  436. (ensure-profile-directory)
  437. ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move
  438. ;; them to %PROFILE-DIRECTORY.
  439. ;;
  440. ;; XXX: Ubuntu's 'sudo' preserves $HOME by default, and thus the second
  441. ;; condition below is always false when one runs "sudo guix pull". As a
  442. ;; workaround, skip this code when $SUDO_USER is set. See
  443. ;; <https://bugs.gnu.org/36785>.
  444. (unless (or (getenv "SUDO_USER")
  445. (string=? %profile-directory
  446. (dirname
  447. (canonicalize-profile %user-profile-directory))))
  448. (migrate-generations %user-profile-directory %profile-directory))
  449. ;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
  450. (let ((link %user-profile-directory))
  451. (unless (equal? (false-if-exception (readlink link))
  452. %current-profile)
  453. (catch 'system-error
  454. (lambda ()
  455. (false-if-exception (delete-file link))
  456. (symlink %current-profile link))
  457. (lambda args
  458. (leave (G_ "while creating symlink '~a': ~a~%")
  459. link (strerror (system-error-errno args))))))))
  460. ;;;
  461. ;;; Queries.
  462. ;;;
  463. (define (display-profile-content profile number)
  464. "Display the packages in PROFILE, generation NUMBER, in a human-readable
  465. way and displaying details about the channel's source code."
  466. (display-generation profile number)
  467. (for-each (lambda (entry)
  468. (format #t " ~a ~a~%"
  469. (manifest-entry-name entry)
  470. (manifest-entry-version entry))
  471. (match (assq 'source (manifest-entry-properties entry))
  472. (('source ('repository ('version 0)
  473. ('url url)
  474. ('branch branch)
  475. ('commit commit)
  476. _ ...))
  477. (format #t (G_ " repository URL: ~a~%") url)
  478. (when branch
  479. (format #t (G_ " branch: ~a~%") branch))
  480. (format #t (G_ " commit: ~a~%") commit))
  481. (_ #f)))
  482. ;; Show most recently installed packages last.
  483. (reverse
  484. (manifest-entries
  485. (profile-manifest (if (zero? number)
  486. profile
  487. (generation-file-name profile number)))))))
  488. (define (indented-string str indent)
  489. "Return STR with each newline preceded by IDENT spaces."
  490. (define indent-string
  491. (make-list indent #\space))
  492. (list->string
  493. (string-fold-right (lambda (chr result)
  494. (if (eqv? chr #\newline)
  495. (cons chr (append indent-string result))
  496. (cons chr result)))
  497. '()
  498. str)))
  499. (define profile-package-alist
  500. (mlambda (profile)
  501. "Return a name/version alist representing the packages in PROFILE."
  502. (let* ((inferior (open-inferior profile))
  503. (packages (inferior-available-packages inferior)))
  504. (close-inferior inferior)
  505. packages)))
  506. (define (new/upgraded-packages alist1 alist2)
  507. "Compare ALIST1 and ALIST2, both of which are lists of package name/version
  508. pairs, and return two values: the list of packages new in ALIST2, and the list
  509. of packages upgraded in ALIST2."
  510. (let* ((old (fold (match-lambda*
  511. (((name . version) table)
  512. (match (vhash-assoc name table)
  513. (#f
  514. (vhash-cons name version table))
  515. ((_ . previous-version)
  516. (if (version>? version previous-version)
  517. (vhash-cons name version table)
  518. table)))))
  519. vlist-null
  520. alist1))
  521. (new (remove (match-lambda
  522. ((name . _)
  523. (vhash-assoc name old)))
  524. alist2))
  525. (upgraded (filter-map (match-lambda
  526. ((name . new-version)
  527. (match (vhash-assoc name old)
  528. (#f #f)
  529. ((_ . old-version)
  530. (and (version>? new-version old-version)
  531. (string-append name "@"
  532. new-version))))))
  533. alist2)))
  534. (values new upgraded)))
  535. (define* (ellipsis #:optional (port (current-output-port)))
  536. "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent
  537. it."
  538. (match (port-encoding port)
  539. ("UTF-8" "…")
  540. (_ "...")))
  541. (define* (display-new/upgraded-packages alist1 alist2
  542. #:key (heading "") concise?)
  543. "Given the two package name/version alists ALIST1 and ALIST2, display the
  544. list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1
  545. and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not
  546. display long package lists that would fill the user's screen.
  547. Return true when there is more package info to display."
  548. (define (pretty str column)
  549. (indented-string (fill-paragraph str (- (%text-width) 4)
  550. column)
  551. 4))
  552. (define concise/max-item-count
  553. ;; Maximum number of items to display when CONCISE? is true.
  554. 12)
  555. (define list->enumeration
  556. (if concise?
  557. (lambda* (lst #:optional (max concise/max-item-count))
  558. (if (> (length lst) max)
  559. (string-append (string-join (take lst max) ", ")
  560. ", " (ellipsis))
  561. (string-join lst ", ")))
  562. (cut string-join <> ", ")))
  563. (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
  564. (define new-count (length new))
  565. (define upgraded-count (length upgraded))
  566. (unless (and (null? new) (null? upgraded))
  567. (display heading))
  568. (match new-count
  569. (0 #t)
  570. (count
  571. (format #t (N_ " ~h new package: ~a~%"
  572. " ~h new packages: ~a~%" count)
  573. count
  574. (pretty (list->enumeration (sort (map first new) string<?))
  575. 30))))
  576. (match upgraded-count
  577. (0 #t)
  578. (count
  579. (format #t (N_ " ~h package upgraded: ~a~%"
  580. " ~h packages upgraded: ~a~%" count)
  581. count
  582. (pretty (list->enumeration (sort upgraded string<?))
  583. 35))))
  584. (and concise?
  585. (or (> new-count concise/max-item-count)
  586. (> upgraded-count concise/max-item-count)))))
  587. (define (display-profile-content-diff profile gen1 gen2)
  588. "Display the changes in PROFILE GEN2 compared to generation GEN1."
  589. (define (package-alist generation)
  590. (profile-package-alist (generation-file-name profile generation)))
  591. (display-profile-content profile gen2)
  592. (display-new/upgraded-packages (package-alist gen1)
  593. (package-alist gen2)))
  594. (define (process-query opts profile)
  595. "Process any query on PROFILE specified by OPTS."
  596. (match (assoc-ref opts 'query)
  597. (('list-generations pattern)
  598. (define (list-generations profile numbers)
  599. (match numbers
  600. ((first rest ...)
  601. (display-profile-content profile first)
  602. (let loop ((numbers numbers))
  603. (match numbers
  604. ((first second rest ...)
  605. (display-profile-content-diff profile
  606. first second)
  607. (display-channel-news (generation-file-name profile second)
  608. (generation-file-name profile first))
  609. (loop (cons second rest)))
  610. ((_) #t)
  611. (() #t))))))
  612. (leave-on-EPIPE
  613. (cond ((not (file-exists? profile)) ; XXX: race condition
  614. (raise (condition (&profile-not-found-error
  615. (profile profile)))))
  616. ((not pattern)
  617. (list-generations profile (profile-generations profile)))
  618. ((matching-generations pattern profile)
  619. =>
  620. (match-lambda
  621. (()
  622. (exit 1))
  623. ((numbers ...)
  624. (list-generations profile numbers)))))))
  625. (('display-news)
  626. (display-news profile))))
  627. (define (process-generation-change opts profile)
  628. "Process a request to change the current generation (roll-back, switch, delete)."
  629. (unless (assoc-ref opts 'dry-run?)
  630. (match (assoc-ref opts 'generation)
  631. (('roll-back)
  632. (with-store store
  633. (roll-back* store profile)))
  634. (('switch pattern)
  635. (let ((number (relative-generation-spec->number profile pattern)))
  636. (if number
  637. (switch-to-generation* profile number)
  638. (leave (G_ "cannot switch to generation '~a'~%") pattern))))
  639. (('delete pattern)
  640. (with-store store
  641. (delete-matching-generations store profile pattern))))))
  642. (define (channel-list opts)
  643. "Return the list of channels to use. If OPTS specify a channel file,
  644. channels are read from there; otherwise, if ~/.config/guix/channels.scm
  645. exists, read it; otherwise %DEFAULT-CHANNELS is used. Apply channel
  646. transformations specified in OPTS (resulting from '--url', '--commit', or
  647. '--branch'), if any."
  648. (define file
  649. (assoc-ref opts 'channel-file))
  650. (define default-file
  651. (string-append (config-directory) "/channels.scm"))
  652. (define (load-channels file)
  653. (let ((result (load* file (make-user-module '((guix channels))))))
  654. (if (and (list? result) (every channel? result))
  655. result
  656. (leave (G_ "'~a' did not return a list of channels~%") file))))
  657. (define channels
  658. (cond (file
  659. (load-channels file))
  660. ((file-exists? default-file)
  661. (load-channels default-file))
  662. (else
  663. %default-channels)))
  664. (define (environment-variable)
  665. (match (getenv "GUIX_PULL_URL")
  666. (#f #f)
  667. (url
  668. (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated.
  669. Use '~/.config/guix/channels.scm' instead."))
  670. url)))
  671. (let ((ref (assoc-ref opts 'ref))
  672. (url (or (assoc-ref opts 'repository-url)
  673. (environment-variable))))
  674. (if (or ref url)
  675. (match (find guix-channel? channels)
  676. ((? channel? guix)
  677. ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel.
  678. (let ((url (or url (channel-url guix))))
  679. (cons (match ref
  680. (('commit . commit)
  681. (channel (inherit guix)
  682. (url url) (commit commit) (branch #f)))
  683. (('branch . branch)
  684. (channel (inherit guix)
  685. (url url) (commit #f) (branch branch)))
  686. (#f
  687. (channel (inherit guix) (url url))))
  688. (remove guix-channel? channels))))
  689. (#f ;no 'guix' channel, failure will ensue
  690. channels))
  691. channels)))
  692. (define (guix-pull . args)
  693. (with-error-handling
  694. (with-git-error-handling
  695. (let* ((opts (parse-command-line args %options
  696. (list %default-options)))
  697. (cache (string-append (cache-directory) "/pull"))
  698. (channels (channel-list opts))
  699. (profile (or (assoc-ref opts 'profile) %current-profile)))
  700. (cond ((assoc-ref opts 'query)
  701. (process-query opts profile))
  702. ((assoc-ref opts 'generation)
  703. (process-generation-change opts profile))
  704. (else
  705. (with-store store
  706. (ensure-default-profile)
  707. (with-status-verbosity (assoc-ref opts 'verbosity)
  708. (parameterize ((%current-system (assoc-ref opts 'system))
  709. (%graft? (assoc-ref opts 'graft?))
  710. (%repository-cache-directory cache))
  711. (set-build-options-from-command-line store opts)
  712. (honor-x509-certificates store)
  713. (let ((instances (latest-channel-instances store channels)))
  714. (format (current-error-port)
  715. (N_ "Building from this channel:~%"
  716. "Building from these channels:~%"
  717. (length instances)))
  718. (for-each (lambda (instance)
  719. (let ((channel
  720. (channel-instance-channel instance)))
  721. (format (current-error-port)
  722. " ~10a~a\t~a~%"
  723. (channel-name channel)
  724. (channel-url channel)
  725. (string-take
  726. (channel-instance-commit instance)
  727. 7))))
  728. instances)
  729. (parameterize ((%guile-for-build
  730. (package-derivation
  731. store
  732. (if (assoc-ref opts 'bootstrap?)
  733. %bootstrap-guile
  734. (canonical-package guile-2.2)))))
  735. (run-with-store store
  736. (build-and-install instances profile
  737. #:dry-run?
  738. (assoc-ref opts 'dry-run?)
  739. #:use-substitutes?
  740. (assoc-ref opts 'substitutes?)
  741. #:verbose?
  742. (assoc-ref opts 'verbose?))))))))))))))
  743. ;;; pull.scm ends here