You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

919 lines
36 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix scripts package)
  21. #:use-module (guix ui)
  22. #:use-module (guix store)
  23. #:use-module (guix derivations)
  24. #:use-module (guix packages)
  25. #:use-module (guix profiles)
  26. #:use-module (guix monads)
  27. #:use-module (guix utils)
  28. #:use-module (guix config)
  29. #:use-module (guix scripts build)
  30. #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
  31. #:use-module (ice-9 format)
  32. #:use-module (ice-9 match)
  33. #:use-module (ice-9 regex)
  34. #:use-module (ice-9 vlist)
  35. #:use-module (srfi srfi-1)
  36. #:use-module (srfi srfi-11)
  37. #:use-module (srfi srfi-19)
  38. #:use-module (srfi srfi-26)
  39. #:use-module (srfi srfi-37)
  40. #:use-module (gnu packages)
  41. #:use-module (gnu packages base)
  42. #:use-module (gnu packages guile)
  43. #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
  44. #:export (specification->package+output
  45. guix-package))
  46. (define %store
  47. (make-parameter #f))
  48. ;;;
  49. ;;; Profiles.
  50. ;;;
  51. (define %user-profile-directory
  52. (and=> (getenv "HOME")
  53. (cut string-append <> "/.guix-profile")))
  54. (define %profile-directory
  55. (string-append %state-directory "/profiles/"
  56. (or (and=> (or (getenv "USER")
  57. (getenv "LOGNAME"))
  58. (cut string-append "per-user/" <>))
  59. "default")))
  60. (define %current-profile
  61. ;; Call it `guix-profile', not `profile', to allow Guix profiles to
  62. ;; coexist with Nix profiles.
  63. (string-append %profile-directory "/guix-profile"))
  64. (define (canonicalize-profile profile)
  65. "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise
  66. return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if
  67. '-p' was omitted." ; see <http://bugs.gnu.org/17939>
  68. (if (and %user-profile-directory
  69. (string=? (canonicalize-path (dirname profile))
  70. (dirname %user-profile-directory))
  71. (string=? (basename profile) (basename %user-profile-directory)))
  72. %current-profile
  73. profile))
  74. (define (link-to-empty-profile generation)
  75. "Link GENERATION, a string, to the empty profile."
  76. (let* ((drv (run-with-store (%store)
  77. (profile-derivation (manifest '()))))
  78. (prof (derivation->output-path drv "out")))
  79. (when (not (build-derivations (%store) (list drv)))
  80. (leave (_ "failed to build the empty profile~%")))
  81. (switch-symlinks generation prof)))
  82. (define (switch-to-previous-generation profile)
  83. "Atomically switch PROFILE to the previous generation."
  84. (let* ((number (generation-number profile))
  85. (previous-number (previous-generation-number profile number))
  86. (previous-generation (generation-file-name profile previous-number)))
  87. (format #t (_ "switching from generation ~a to ~a~%")
  88. number previous-number)
  89. (switch-symlinks profile previous-generation)))
  90. (define (roll-back profile)
  91. "Roll back to the previous generation of PROFILE."
  92. (let* ((number (generation-number profile))
  93. (previous-number (previous-generation-number profile number))
  94. (previous-generation (generation-file-name profile previous-number)))
  95. (cond ((not (file-exists? profile)) ; invalid profile
  96. (leave (_ "profile '~a' does not exist~%")
  97. profile))
  98. ((zero? number) ; empty profile
  99. (format (current-error-port)
  100. (_ "nothing to do: already at the empty profile~%")))
  101. ((or (zero? previous-number) ; going to emptiness
  102. (not (file-exists? previous-generation)))
  103. (link-to-empty-profile previous-generation)
  104. (switch-to-previous-generation profile))
  105. (else
  106. (switch-to-previous-generation profile))))) ; anything else
  107. (define* (matching-generations str #:optional (profile %current-profile)
  108. #:key (duration-relation <=))
  109. "Return the list of available generations matching a pattern in STR. See
  110. 'string->generations' and 'string->duration' for the list of valid patterns.
  111. When STR is a duration pattern, return all the generations whose ctime has
  112. DURATION-RELATION with the current time."
  113. (define (valid-generations lst)
  114. (define (valid-generation? n)
  115. (any (cut = n <>) (generation-numbers profile)))
  116. (fold-right (lambda (x acc)
  117. (if (valid-generation? x)
  118. (cons x acc)
  119. acc))
  120. '()
  121. lst))
  122. (define (filter-generations generations)
  123. (match generations
  124. (() '())
  125. (('>= n)
  126. (drop-while (cut > n <>)
  127. (generation-numbers profile)))
  128. (('<= n)
  129. (valid-generations (iota n 1)))
  130. ((lst ..1)
  131. (valid-generations lst))
  132. (_ #f)))
  133. (define (filter-by-duration duration)
  134. (define (time-at-midnight time)
  135. ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
  136. ;; hours to zeros.
  137. (let ((d (time-utc->date time)))
  138. (date->time-utc
  139. (make-date 0 0 0 0
  140. (date-day d) (date-month d)
  141. (date-year d) (date-zone-offset d)))))
  142. (define generation-ctime-alist
  143. (map (lambda (number)
  144. (cons number
  145. (time-second
  146. (time-at-midnight
  147. (generation-time profile number)))))
  148. (generation-numbers profile)))
  149. (match duration
  150. (#f #f)
  151. (res
  152. (let ((s (time-second
  153. (subtract-duration (time-at-midnight (current-time))
  154. duration))))
  155. (delete #f (map (lambda (x)
  156. (and (duration-relation s (cdr x))
  157. (first x)))
  158. generation-ctime-alist))))))
  159. (cond ((string->generations str)
  160. =>
  161. filter-generations)
  162. ((string->duration str)
  163. =>
  164. filter-by-duration)
  165. (else #f)))
  166. ;;;
  167. ;;; Package specifications.
  168. ;;;
  169. (define (find-packages-by-description rx)
  170. "Return the list of packages whose name, synopsis, or description matches
  171. RX."
  172. (define (same-location? p1 p2)
  173. ;; Compare locations of two packages.
  174. (equal? (package-location p1) (package-location p2)))
  175. (delete-duplicates
  176. (sort
  177. (fold-packages (lambda (package result)
  178. (define matches?
  179. (cut regexp-exec rx <>))
  180. (if (or (matches? (package-name package))
  181. (and=> (package-synopsis package)
  182. (compose matches? P_))
  183. (and=> (package-description package)
  184. (compose matches? P_)))
  185. (cons package result)
  186. result))
  187. '())
  188. (lambda (p1 p2)
  189. (string<? (package-name p1)
  190. (package-name p2))))
  191. same-location?))
  192. (define-syntax-rule (leave-on-EPIPE exp ...)
  193. "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
  194. with successful exit code. This is useful when writing to the standard output
  195. may lead to EPIPE, because the standard output is piped through 'head' or
  196. similar."
  197. (catch 'system-error
  198. (lambda ()
  199. exp ...)
  200. (lambda args
  201. ;; We really have to exit this brutally, otherwise Guile eventually
  202. ;; attempts to flush all the ports, leading to an uncaught EPIPE down
  203. ;; the path.
  204. (if (= EPIPE (system-error-errno args))
  205. (primitive-_exit 0)
  206. (apply throw args)))))
  207. (define* (specification->package+output spec #:optional (output "out"))
  208. "Return the package and output specified by SPEC, or #f and #f; SPEC may
  209. optionally contain a version number and an output name, as in these examples:
  210. guile
  211. guile-2.0.9
  212. guile:debug
  213. guile-2.0.9:debug
  214. If SPEC does not specify a version number, return the preferred newest
  215. version; if SPEC does not specify an output, return OUTPUT."
  216. (define (ensure-output p sub-drv)
  217. (if (member sub-drv (package-outputs p))
  218. sub-drv
  219. (leave (_ "package `~a' lacks output `~a'~%")
  220. (package-full-name p)
  221. sub-drv)))
  222. (let-values (((name version sub-drv)
  223. (package-specification->name+version+output spec output)))
  224. (match (find-best-packages-by-name name version)
  225. ((p)
  226. (values p (ensure-output p sub-drv)))
  227. ((p p* ...)
  228. (warning (_ "ambiguous package specification `~a'~%")
  229. spec)
  230. (warning (_ "choosing ~a from ~a~%")
  231. (package-full-name p)
  232. (location->string (package-location p)))
  233. (values p (ensure-output p sub-drv)))
  234. (()
  235. (leave (_ "~a: package not found~%") spec)))))
  236. (define (upgradeable? name current-version current-path)
  237. "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
  238. or if the newest available version is equal to CURRENT-VERSION but would have
  239. an output path different than CURRENT-PATH."
  240. (match (vhash-assoc name (find-newest-available-packages))
  241. ((_ candidate-version pkg . rest)
  242. (case (version-compare candidate-version current-version)
  243. ((>) #t)
  244. ((<) #f)
  245. ((=) (let ((candidate-path (derivation->output-path
  246. (package-derivation (%store) pkg))))
  247. (not (string=? current-path candidate-path))))))
  248. (#f #f)))
  249. ;;;
  250. ;;; Search paths.
  251. ;;;
  252. (define* (search-path-environment-variables entries profile
  253. #:optional (getenv getenv))
  254. "Return environment variable definitions that may be needed for the use of
  255. ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the
  256. current settings and report only settings not already effective."
  257. ;; Prefer ~/.guix-profile to the real profile directory name.
  258. (let ((profile (if (and %user-profile-directory
  259. (false-if-exception
  260. (string=? (readlink %user-profile-directory)
  261. profile)))
  262. %user-profile-directory
  263. profile)))
  264. ;; The search path info is not stored in the manifest. Thus, we infer the
  265. ;; search paths from same-named packages found in the distro.
  266. (define manifest-entry->package
  267. (match-lambda
  268. (($ <manifest-entry> name version)
  269. ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
  270. ;; the former traverses the module tree only once and then allows for
  271. ;; efficient access via a vhash.
  272. (match (find-best-packages-by-name name version)
  273. ((p _ ...) p)
  274. (_
  275. (match (find-best-packages-by-name name #f)
  276. ((p _ ...) p)
  277. (_ #f)))))))
  278. (define search-path-definition
  279. (match-lambda
  280. (($ <search-path-specification> variable directories separator)
  281. (let ((values (or (and=> (getenv variable)
  282. (cut string-tokenize* <> separator))
  283. '()))
  284. (directories (filter file-exists?
  285. (map (cut string-append profile
  286. "/" <>)
  287. directories))))
  288. (if (every (cut member <> values) directories)
  289. #f
  290. (format #f "export ~a=\"~a\""
  291. variable
  292. (string-join directories separator)))))))
  293. (let* ((packages (filter-map manifest-entry->package entries))
  294. (search-paths (delete-duplicates
  295. (append-map package-native-search-paths
  296. packages))))
  297. (filter-map search-path-definition search-paths))))
  298. (define (display-search-paths entries profile)
  299. "Display the search path environment variables that may need to be set for
  300. ENTRIES, a list of manifest entries, in the context of PROFILE."
  301. (let ((settings (search-path-environment-variables entries profile)))
  302. (unless (null? settings)
  303. (format #t (_ "The following environment variable definitions may be needed:~%"))
  304. (format #t "~{ ~a~%~}" settings))))
  305. ;;;
  306. ;;; Command-line options.
  307. ;;;
  308. (define %default-options
  309. ;; Alist of default option values.
  310. `((profile . ,%current-profile)
  311. (max-silent-time . 3600)
  312. (verbosity . 0)
  313. (substitutes? . #t)))
  314. (define (show-help)
  315. (display (_ "Usage: guix package [OPTION]... PACKAGES...
  316. Install, remove, or upgrade PACKAGES in a single transaction.\n"))
  317. (display (_ "
  318. -i, --install=PACKAGE install PACKAGE"))
  319. (display (_ "
  320. -e, --install-from-expression=EXP
  321. install the package EXP evaluates to"))
  322. (display (_ "
  323. -r, --remove=PACKAGE remove PACKAGE"))
  324. (display (_ "
  325. -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
  326. (display (_ "
  327. --roll-back roll back to the previous generation"))
  328. (display (_ "
  329. --search-paths display needed environment variable definitions"))
  330. (display (_ "
  331. -l, --list-generations[=PATTERN]
  332. list generations matching PATTERN"))
  333. (display (_ "
  334. -d, --delete-generations[=PATTERN]
  335. delete generations matching PATTERN"))
  336. (display (_ "
  337. -p, --profile=PROFILE use PROFILE instead of the user's default profile"))
  338. (newline)
  339. (display (_ "
  340. --bootstrap use the bootstrap Guile to build the profile"))
  341. (display (_ "
  342. --verbose produce verbose output"))
  343. (newline)
  344. (display (_ "
  345. -s, --search=REGEXP search in synopsis and description using REGEXP"))
  346. (display (_ "
  347. -I, --list-installed[=REGEXP]
  348. list installed packages matching REGEXP"))
  349. (display (_ "
  350. -A, --list-available[=REGEXP]
  351. list available packages matching REGEXP"))
  352. (display (_ "
  353. --show=PACKAGE show details about PACKAGE"))
  354. (newline)
  355. (show-build-options-help)
  356. (newline)
  357. (display (_ "
  358. -h, --help display this help and exit"))
  359. (display (_ "
  360. -V, --version display version information and exit"))
  361. (newline)
  362. (show-bug-report-information))
  363. (define %options
  364. ;; Specification of the command-line options.
  365. (cons* (option '(#\h "help") #f #f
  366. (lambda args
  367. (show-help)
  368. (exit 0)))
  369. (option '(#\V "version") #f #f
  370. (lambda args
  371. (show-version-and-exit "guix package")))
  372. (option '(#\i "install") #f #t
  373. (lambda (opt name arg result arg-handler)
  374. (let arg-handler ((arg arg) (result result))
  375. (values (if arg
  376. (alist-cons 'install arg result)
  377. result)
  378. arg-handler))))
  379. (option '(#\e "install-from-expression") #t #f
  380. (lambda (opt name arg result arg-handler)
  381. (values (alist-cons 'install (read/eval-package-expression arg)
  382. result)
  383. #f)))
  384. (option '(#\r "remove") #f #t
  385. (lambda (opt name arg result arg-handler)
  386. (let arg-handler ((arg arg) (result result))
  387. (values (if arg
  388. (alist-cons 'remove arg result)
  389. result)
  390. arg-handler))))
  391. (option '(#\u "upgrade") #f #t
  392. (lambda (opt name arg result arg-handler)
  393. (let arg-handler ((arg arg) (result result))
  394. (values (alist-cons 'upgrade arg
  395. ;; Delete any prior "upgrade all"
  396. ;; command, or else "--upgrade gcc"
  397. ;; would upgrade everything.
  398. (delete '(upgrade . #f) result))
  399. arg-handler))))
  400. (option '("roll-back") #f #f
  401. (lambda (opt name arg result arg-handler)
  402. (values (alist-cons 'roll-back? #t result)
  403. #f)))
  404. (option '(#\l "list-generations") #f #t
  405. (lambda (opt name arg result arg-handler)
  406. (values (cons `(query list-generations ,(or arg ""))
  407. result)
  408. #f)))
  409. (option '(#\d "delete-generations") #f #t
  410. (lambda (opt name arg result arg-handler)
  411. (values (alist-cons 'delete-generations (or arg "")
  412. result)
  413. #f)))
  414. (option '("search-paths") #f #f
  415. (lambda (opt name arg result arg-handler)
  416. (values (cons `(query search-paths) result)
  417. #f)))
  418. (option '(#\p "profile") #t #f
  419. (lambda (opt name arg result arg-handler)
  420. (values (alist-cons 'profile (canonicalize-profile arg)
  421. (alist-delete 'profile result))
  422. #f)))
  423. (option '(#\n "dry-run") #f #f
  424. (lambda (opt name arg result arg-handler)
  425. (values (alist-cons 'dry-run? #t result)
  426. #f)))
  427. (option '("bootstrap") #f #f
  428. (lambda (opt name arg result arg-handler)
  429. (values (alist-cons 'bootstrap? #t result)
  430. #f)))
  431. (option '("verbose") #f #f
  432. (lambda (opt name arg result arg-handler)
  433. (values (alist-cons 'verbose? #t result)
  434. #f)))
  435. (option '(#\s "search") #t #f
  436. (lambda (opt name arg result arg-handler)
  437. (values (cons `(query search ,(or arg ""))
  438. result)
  439. #f)))
  440. (option '(#\I "list-installed") #f #t
  441. (lambda (opt name arg result arg-handler)
  442. (values (cons `(query list-installed ,(or arg ""))
  443. result)
  444. #f)))
  445. (option '(#\A "list-available") #f #t
  446. (lambda (opt name arg result arg-handler)
  447. (values (cons `(query list-available ,(or arg ""))
  448. result)
  449. #f)))
  450. (option '("show") #t #t
  451. (lambda (opt name arg result arg-handler)
  452. (values (cons `(query show ,arg)
  453. result)
  454. #f)))
  455. %standard-build-options))
  456. (define (options->installable opts manifest)
  457. "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
  458. return the new list of manifest entries."
  459. (define (package->manifest-entry* package output)
  460. (check-package-freshness package)
  461. ;; When given a package via `-e', install the first of its
  462. ;; outputs (XXX).
  463. (package->manifest-entry package output))
  464. (define upgrade-regexps
  465. (filter-map (match-lambda
  466. (('upgrade . regexp)
  467. (make-regexp (or regexp "")))
  468. (_ #f))
  469. opts))
  470. (define packages-to-upgrade
  471. (match upgrade-regexps
  472. (()
  473. '())
  474. ((_ ...)
  475. (filter-map (match-lambda
  476. (($ <manifest-entry> name version output path _)
  477. (and (any (cut regexp-exec <> name)
  478. upgrade-regexps)
  479. (upgradeable? name version path)
  480. (let ((output (or output "out")))
  481. (call-with-values
  482. (lambda ()
  483. (specification->package+output name output))
  484. list))))
  485. (_ #f))
  486. (manifest-entries manifest)))))
  487. (define to-upgrade
  488. (map (match-lambda
  489. ((package output)
  490. (package->manifest-entry* package output)))
  491. packages-to-upgrade))
  492. (define packages-to-install
  493. (filter-map (match-lambda
  494. (('install . (? package? p))
  495. (list p "out"))
  496. (('install . (? string? spec))
  497. (and (not (store-path? spec))
  498. (let-values (((package output)
  499. (specification->package+output spec)))
  500. (and package (list package output)))))
  501. (_ #f))
  502. opts))
  503. (define to-install
  504. (append (map (match-lambda
  505. ((package output)
  506. (package->manifest-entry* package output)))
  507. packages-to-install)
  508. (filter-map (match-lambda
  509. (('install . (? package?))
  510. #f)
  511. (('install . (? store-path? path))
  512. (let-values (((name version)
  513. (package-name->name+version
  514. (store-path-package-name path))))
  515. (manifest-entry
  516. (name name)
  517. (version version)
  518. (output #f)
  519. (item path))))
  520. (_ #f))
  521. opts)))
  522. (append to-upgrade to-install))
  523. (define (options->removable options manifest)
  524. "Given options, return the list of manifest patterns of packages to be
  525. removed from MANIFEST."
  526. (filter-map (match-lambda
  527. (('remove . spec)
  528. (call-with-values
  529. (lambda ()
  530. (package-specification->name+version+output spec))
  531. (lambda (name version output)
  532. (manifest-pattern
  533. (name name)
  534. (version version)
  535. (output output)))))
  536. (_ #f))
  537. options))
  538. (define (maybe-register-gc-root store profile)
  539. "Register PROFILE as a GC root, unless it doesn't need it."
  540. (unless (string=? profile %current-profile)
  541. (add-indirect-root store (canonicalize-path profile))))
  542. (define (readlink* file)
  543. "Call 'readlink' until the result is not a symlink."
  544. (catch 'system-error
  545. (lambda ()
  546. (readlink* (readlink file)))
  547. (lambda args
  548. (if (= EINVAL (system-error-errno args))
  549. file
  550. (apply throw args)))))
  551. ;;;
  552. ;;; Entry point.
  553. ;;;
  554. (define (guix-package . args)
  555. (define (parse-options)
  556. ;; Return the alist of option values.
  557. (args-fold* args %options
  558. (lambda (opt name arg result arg-handler)
  559. (leave (_ "~A: unrecognized option~%") name))
  560. (lambda (arg result arg-handler)
  561. (if arg-handler
  562. (arg-handler arg result)
  563. (leave (_ "~A: extraneous argument~%") arg)))
  564. %default-options
  565. #f))
  566. (define (ensure-default-profile)
  567. ;; Ensure the default profile symlink and directory exist and are
  568. ;; writable.
  569. (define (rtfm)
  570. (format (current-error-port)
  571. (_ "Try \"info '(guix) Invoking guix package'\" for \
  572. more information.~%"))
  573. (exit 1))
  574. ;; Create ~/.guix-profile if it doesn't exist yet.
  575. (when (and %user-profile-directory
  576. %current-profile
  577. (not (false-if-exception
  578. (lstat %user-profile-directory))))
  579. (symlink %current-profile %user-profile-directory))
  580. (let ((s (stat %profile-directory #f)))
  581. ;; Attempt to create /…/profiles/per-user/$USER if needed.
  582. (unless (and s (eq? 'directory (stat:type s)))
  583. (catch 'system-error
  584. (lambda ()
  585. (mkdir-p %profile-directory))
  586. (lambda args
  587. ;; Often, we cannot create %PROFILE-DIRECTORY because its
  588. ;; parent directory is root-owned and we're running
  589. ;; unprivileged.
  590. (format (current-error-port)
  591. (_ "error: while creating directory `~a': ~a~%")
  592. %profile-directory
  593. (strerror (system-error-errno args)))
  594. (format (current-error-port)
  595. (_ "Please create the `~a' directory, with you as the owner.~%")
  596. %profile-directory)
  597. (rtfm))))
  598. ;; Bail out if it's not owned by the user.
  599. (unless (or (not s) (= (stat:uid s) (getuid)))
  600. (format (current-error-port)
  601. (_ "error: directory `~a' is not owned by you~%")
  602. %profile-directory)
  603. (format (current-error-port)
  604. (_ "Please change the owner of `~a' to user ~s.~%")
  605. %profile-directory (or (getenv "USER")
  606. (getenv "LOGNAME")
  607. (getuid)))
  608. (rtfm))))
  609. (define (process-actions opts)
  610. ;; Process any install/remove/upgrade action from OPTS.
  611. (define dry-run? (assoc-ref opts 'dry-run?))
  612. (define profile (assoc-ref opts 'profile))
  613. (define current-generation-number
  614. (generation-number profile))
  615. (define (display-and-delete number)
  616. (let ((generation (generation-file-name profile number)))
  617. (unless (zero? number)
  618. (format #t (_ "deleting ~a~%") generation)
  619. (delete-file generation))))
  620. (define (delete-generation number)
  621. (let* ((previous-number (previous-generation-number profile number))
  622. (previous-generation
  623. (generation-file-name profile previous-number)))
  624. (cond ((zero? number)) ; do not delete generation 0
  625. ((and (= number current-generation-number)
  626. (not (file-exists? previous-generation)))
  627. (link-to-empty-profile previous-generation)
  628. (switch-to-previous-generation profile)
  629. (display-and-delete number))
  630. ((= number current-generation-number)
  631. (roll-back profile)
  632. (display-and-delete number))
  633. (else
  634. (display-and-delete number)))))
  635. ;; First roll back if asked to.
  636. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?))
  637. (begin
  638. (roll-back profile)
  639. (process-actions (alist-delete 'roll-back? opts))))
  640. ((and (assoc-ref opts 'delete-generations)
  641. (not dry-run?))
  642. (filter-map
  643. (match-lambda
  644. (('delete-generations . pattern)
  645. (cond ((not (file-exists? profile)) ; XXX: race condition
  646. (leave (_ "profile '~a' does not exist~%")
  647. profile))
  648. ((string-null? pattern)
  649. (for-each display-and-delete
  650. (delete current-generation-number
  651. (profile-generations profile))))
  652. ;; Do not delete the zeroth generation.
  653. ((equal? 0 (string->number pattern))
  654. (exit 0))
  655. ;; If PATTERN is a duration, match generations that are
  656. ;; older than the specified duration.
  657. ((matching-generations pattern profile
  658. #:duration-relation >)
  659. =>
  660. (lambda (numbers)
  661. (if (null-list? numbers)
  662. (exit 1)
  663. (for-each delete-generation numbers))))
  664. (else
  665. (leave (_ "invalid syntax: ~a~%")
  666. pattern)))
  667. (process-actions
  668. (alist-delete 'delete-generations opts)))
  669. (_ #f))
  670. opts))
  671. (else
  672. (let* ((manifest (profile-manifest profile))
  673. (install (options->installable opts manifest))
  674. (remove (options->removable opts manifest))
  675. (bootstrap? (assoc-ref opts 'bootstrap?))
  676. (transaction (manifest-transaction (install install)
  677. (remove remove)))
  678. (new (manifest-perform-transaction
  679. manifest transaction)))
  680. (when (equal? profile %current-profile)
  681. (ensure-default-profile))
  682. (unless (and (null? install) (null? remove))
  683. (let* ((prof-drv (run-with-store (%store)
  684. (profile-derivation
  685. new
  686. #:info-dir? (not bootstrap?))))
  687. (prof (derivation->output-path prof-drv)))
  688. (manifest-show-transaction (%store) manifest transaction
  689. #:dry-run? dry-run?)
  690. (show-what-to-build (%store) (list prof-drv)
  691. #:use-substitutes?
  692. (assoc-ref opts 'substitutes?)
  693. #:dry-run? dry-run?)
  694. (cond
  695. (dry-run? #t)
  696. ((and (file-exists? profile)
  697. (and=> (readlink* profile) (cut string=? prof <>)))
  698. (format (current-error-port) (_ "nothing to be done~%")))
  699. (else
  700. (let* ((number (generation-number profile))
  701. ;; Always use NUMBER + 1 for the new profile,
  702. ;; possibly overwriting a "previous future
  703. ;; generation".
  704. (name (generation-file-name profile
  705. (+ 1 number))))
  706. (and (build-derivations (%store) (list prof-drv))
  707. (let* ((entries (manifest-entries new))
  708. (count (length entries)))
  709. (switch-symlinks name prof)
  710. (switch-symlinks profile name)
  711. (maybe-register-gc-root (%store) profile)
  712. (format #t (N_ "~a package in profile~%"
  713. "~a packages in profile~%"
  714. count)
  715. count)
  716. (display-search-paths entries
  717. profile))))))))))))
  718. (define (process-query opts)
  719. ;; Process any query specified by OPTS. Return #t when a query was
  720. ;; actually processed, #f otherwise.
  721. (let ((profile (assoc-ref opts 'profile)))
  722. (match (assoc-ref opts 'query)
  723. (('list-generations pattern)
  724. (define (list-generation number)
  725. (unless (zero? number)
  726. (let ((header (format #f (_ "Generation ~a\t~a") number
  727. (date->string
  728. (time-utc->date
  729. (generation-time profile number))
  730. "~b ~d ~Y ~T")))
  731. (current (generation-number profile)))
  732. (if (= number current)
  733. (format #t (_ "~a\t(current)~%") header)
  734. (format #t "~a~%" header)))
  735. (for-each (match-lambda
  736. (($ <manifest-entry> name version output location _)
  737. (format #t " ~a\t~a\t~a\t~a~%"
  738. name version output location)))
  739. ;; Show most recently installed packages last.
  740. (reverse
  741. (manifest-entries
  742. (profile-manifest
  743. (generation-file-name profile number)))))
  744. (newline)))
  745. (cond ((not (file-exists? profile)) ; XXX: race condition
  746. (leave (_ "profile '~a' does not exist~%")
  747. profile))
  748. ((string-null? pattern)
  749. (for-each list-generation (profile-generations profile)))
  750. ((matching-generations pattern profile)
  751. =>
  752. (lambda (numbers)
  753. (if (null-list? numbers)
  754. (exit 1)
  755. (leave-on-EPIPE
  756. (for-each list-generation numbers)))))
  757. (else
  758. (leave (_ "invalid syntax: ~a~%")
  759. pattern)))
  760. #t)
  761. (('list-installed regexp)
  762. (let* ((regexp (and regexp (make-regexp regexp)))
  763. (manifest (profile-manifest profile))
  764. (installed (manifest-entries manifest)))
  765. (leave-on-EPIPE
  766. (for-each (match-lambda
  767. (($ <manifest-entry> name version output path _)
  768. (when (or (not regexp)
  769. (regexp-exec regexp name))
  770. (format #t "~a\t~a\t~a\t~a~%"
  771. name (or version "?") output path))))
  772. ;; Show most recently installed packages last.
  773. (reverse installed)))
  774. #t))
  775. (('list-available regexp)
  776. (let* ((regexp (and regexp (make-regexp regexp)))
  777. (available (fold-packages
  778. (lambda (p r)
  779. (let ((n (package-name p)))
  780. (if regexp
  781. (if (regexp-exec regexp n)
  782. (cons p r)
  783. r)
  784. (cons p r))))
  785. '())))
  786. (leave-on-EPIPE
  787. (for-each (lambda (p)
  788. (format #t "~a\t~a\t~a\t~a~%"
  789. (package-name p)
  790. (package-version p)
  791. (string-join (package-outputs p) ",")
  792. (location->string (package-location p))))
  793. (sort available
  794. (lambda (p1 p2)
  795. (string<? (package-name p1)
  796. (package-name p2))))))
  797. #t))
  798. (('search regexp)
  799. (let ((regexp (make-regexp regexp regexp/icase)))
  800. (leave-on-EPIPE
  801. (for-each (cute package->recutils <> (current-output-port))
  802. (find-packages-by-description regexp)))
  803. #t))
  804. (('show requested-name)
  805. (let-values (((name version)
  806. (package-name->name+version requested-name)))
  807. (leave-on-EPIPE
  808. (for-each (cute package->recutils <> (current-output-port))
  809. (find-packages-by-name name version)))
  810. #t))
  811. (('search-paths)
  812. (let* ((manifest (profile-manifest profile))
  813. (entries (manifest-entries manifest))
  814. (settings (search-path-environment-variables entries profile
  815. (const #f))))
  816. (format #t "~{~a~%~}" settings)
  817. #t))
  818. (_ #f))))
  819. (let ((opts (parse-options)))
  820. (or (process-query opts)
  821. (with-error-handling
  822. (parameterize ((%store (open-connection)))
  823. (set-build-options-from-command-line (%store) opts)
  824. (parameterize ((%guile-for-build
  825. (package-derivation
  826. (%store)
  827. (if (assoc-ref opts 'bootstrap?)
  828. %bootstrap-guile
  829. (canonical-package guile-2.0)))))
  830. (process-actions opts)))))))