nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guix package: Formalize the list of actions. 

* guix/scripts/package.scm (roll-back-action, switch-generation-action)
(delete-generations-action, manifest-action): New procedures.
(%actions): New variable.
* guix/scripts/package.scm (guix-package)[process-action]: Rewrite to
traverse %ACTIONS.
This commit is contained in:
Ludovic Courtès 2015-11-30 13:46:31 +01:00
parent 50dc193e27
commit 590558953b
1 changed files with 79 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
guix/scripts/package.scm
View File

@ -624,6 +624,11 @@ doesn't need it."
(add-indirect-root store absolute)) (add-indirect-root store absolute))
;;;
;;; Queries and actions.
;;;
(define (process-query opts) (define (process-query opts)
"Process any query specified by OPTS. Return #t when a query was actually "Process any query specified by OPTS. Return #t when a query was actually
processed, #f otherwise." processed, #f otherwise."
@ -729,6 +734,58 @@ processed, #f otherwise."
(_ #f)))) (_ #f))))
(define* (roll-back-action store profile arg opts
#:key dry-run?)
"Roll back PROFILE to its previous generation."
(unless dry-run?
(roll-back* store profile)))
(define* (switch-generation-action store profile spec opts
#:key dry-run?)
"Switch PROFILE to the generation specified by SPEC."
(unless dry-run?
(let* ((number (string->number spec))
(number (and number
(case (string-ref spec 0)
((#\+ #\-)
(relative-generation profile number))
(else number)))))
(if number
(switch-to-generation* profile number)
(leave (_ "cannot switch to generation '~a'~%") spec)))))
(define* (delete-generations-action store profile pattern opts
#:key dry-run?)
"Delete PROFILE's generations that match PATTERN."
(unless dry-run?
(delete-matching-generations store profile pattern)))
(define* (manifest-action store profile file opts
#:key dry-run?)
"Change PROFILE to contain the packages specified in FILE."
(let* ((user-module (make-user-module '((guix profiles) (gnu))))
(manifest (load* file user-module))
(bootstrap? (assoc-ref opts 'bootstrap?))
(substitutes? (assoc-ref opts 'substitutes?)))
(if dry-run?
(format #t (_ "would install new manifest from '~a' with ~d entries~%")
file (length (manifest-entries manifest)))
(format #t (_ "installing new manifest from '~a' with ~d entries~%")
file (length (manifest-entries manifest))))
(build-and-use-profile store profile manifest
#:bootstrap? bootstrap?
#:use-substitutes? substitutes?
#:dry-run? dry-run?)))
(define %actions
;; List of actions that may be processed. The car of each pair is the
;; action's symbol in the option list; the cdr is the action's procedure.
`((roll-back? . ,roll-back-action)
(switch-generation . ,switch-generation-action)
(delete-generations . ,delete-generations-action)
(manifest . ,manifest-action)))
;;; ;;;
;;; Entry point. ;;; Entry point.
@ -749,70 +806,30 @@ processed, #f otherwise."
(define substitutes? (assoc-ref opts 'substitutes?)) (define substitutes? (assoc-ref opts 'substitutes?))
(define profile (or (assoc-ref opts 'profile) %current-profile)) (define profile (or (assoc-ref opts 'profile) %current-profile))
;; First roll back if asked to. ;; First, process roll-backs, generation removals, etc.
(cond ((and (assoc-ref opts 'roll-back?) (for-each (match-lambda
(not dry-run?)) ((key . arg)
(roll-back* (%store) profile) (and=> (assoc-ref %actions key)
(process-actions (alist-delete 'roll-back? opts))) (lambda (proc)
((and (assoc-ref opts 'switch-generation) (proc (%store) profile arg opts
(not dry-run?)) #:dry-run? dry-run?)))))
(for-each opts)
(match-lambda
(('switch-generation . pattern)
(let* ((number (string->number pattern))
(number (and number
(case (string-ref pattern 0)
((#\+ #\-)
(relative-generation profile number))
(else number)))))
(if number
(switch-to-generation* profile number)
(leave (_ "cannot switch to generation '~a'~%")
pattern)))
(process-actions (alist-delete 'switch-generation opts)))
(_ #f))
opts))
((and (assoc-ref opts 'delete-generations)
(not dry-run?))
(for-each
(match-lambda
(('delete-generations . pattern)
(delete-matching-generations (%store) profile pattern)
(process-actions ;; Then, process normal package installation/removal/upgrade.
(alist-delete 'delete-generations opts))) (let* ((manifest (profile-manifest profile))
(_ #f)) (install (options->installable opts manifest))
opts)) (remove (options->removable opts manifest))
((assoc-ref opts 'manifest) (transaction (manifest-transaction (install install)
(let* ((file-name (assoc-ref opts 'manifest)) (remove remove)))
(user-module (make-user-module '((guix profiles) (new (manifest-perform-transaction manifest transaction)))
(gnu))))
(manifest (load* file-name user-module)))
(if dry-run?
(format #t (_ "would install new manifest from '~a' with ~d entries~%")
file-name (length (manifest-entries manifest)))
(format #t (_ "installing new manifest from '~a' with ~d entries~%")
file-name (length (manifest-entries manifest))))
(build-and-use-profile (%store) profile manifest
#:bootstrap? bootstrap?
#:use-substitutes? substitutes?
#:dry-run? dry-run?)))
(else
(let* ((manifest (profile-manifest profile))
(install (options->installable opts manifest))
(remove (options->removable opts manifest))
(transaction (manifest-transaction (install install)
(remove remove)))
(new (manifest-perform-transaction
manifest transaction)))
(unless (and (null? install) (null? remove)) (unless (and (null? install) (null? remove))
(show-manifest-transaction (%store) manifest transaction (show-manifest-transaction (%store) manifest transaction
#:dry-run? dry-run?) #:dry-run? dry-run?)
(build-and-use-profile (%store) profile new (build-and-use-profile (%store) profile new
#:bootstrap? bootstrap? #:bootstrap? bootstrap?
#:use-substitutes? substitutes? #:use-substitutes? substitutes?
#:dry-run? dry-run?)))))) #:dry-run? dry-run?))))
(let ((opts (parse-command-line args %options (list %default-options #f) (let ((opts (parse-command-line args %options (list %default-options #f)
#:argument-handler handle-argument))) #:argument-handler handle-argument)))