--- guix-package-orig 2013-01-09 18:28:03.000000000 +0000 +++ guix-package 2013-01-09 18:38:23.000000000 +0000 @@ -13,6 +13,7 @@ !# ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 optargs) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -88,13 +90,14 @@ (_ (error "unsupported manifest format" manifest)))) +(define (profile-rx profile) + "Return a regular expression that matches PROFILE's name and number." + (make-regexp (string-append "^" (regexp-quote (basename profile)) + "-([0-9]+)"))) + (define (latest-profile-number profile) "Return the identifying number of the latest generation of PROFILE. PROFILE is the name of the symlink to the current generation." - (define %profile-rx - (make-regexp (string-append "^" (regexp-quote (basename profile)) - "-([0-9]+)"))) - (define* (scandir name #:optional (select? (const #t)) (entry)) + (cut regexp-exec (profile-rx profile) <>)) (#f ; no profile directory 0) (() ; no profiles @@ -138,7 +141,7 @@ ((profiles ...) ; former profiles around (let ((numbers (map (compose string->number (cut match:substring <> 1) - (cut regexp-exec %profile-rx <>)) + (cut regexp-exec (profile-rx profile) <>)) profiles))) (fold (lambda (number highest) (if (> number highest) @@ -178,6 +181,41 @@ packages) #:modules '((guix build union)))) +(define (profile-number profile) + "Return PROFILE's number. An absolute file name must be used." + (and=> (regexp-exec (profile-rx profile) + (basename (readlink profile))) + (cut match:substring <> 1))) + +(define* (roll-back #:optional profile) + "Roll back to the previous profile." + (let* ((current-profile-number + (string->number (profile-number (or profile %current-profile)))) + (previous-profile-number (number->string (1- current-profile-number))) + (previous-profile + (string-append (or profile %current-profile) "-" + previous-profile-number "-link")) + (manifest (string-append previous-profile "/manifest"))) + + (define (switch-link) + ;; Switch to the previous generation. + (let ((tmp-profile (string-append (dirname (or profile %current-profile)) + "/tmp-" + (basename previous-profile)))) + + (simple-format #t "guix-package: switching from generation ~a to ~a~%" + current-profile-number previous-profile-number) + (symlink previous-profile tmp-profile) + (rename-file tmp-profile (or profile %current-profile)))) + + (if (equal? (map (cut file-exists? <>) + (list previous-profile manifest)) + '(#t #t)) + (switch-link) + (leave (_ (string-append + "guix-package: previous profile doesn't exist; " + "not rolling back~%")))))) + ;;; ;;; Command-line options. @@ -202,6 +240,8 @@ (display (_ " -n, --dry-run show what would be done without actually doing it")) (display (_ " + --roll-back roll back to the previous generation")) + (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " --verbose produce verbose output")) @@ -236,6 +276,25 @@ (option '(#\r "remove") #t #f (lambda (opt name arg result) (alist-cons 'remove arg result))) + + ;; (option '("roll-back") #f #t + ;; (lambda (opt name arg result) + ;; (roll-back (or arg #f)) + ;; (exit 0))) + + ;; (lambda (opt name arg result) + ;; (alist-cons 'roll-back arg result))) + + ;; (lambda (opt name arg result) + ;; (cons `(query roll-back ,(or arg #f)) + ;; result))) + + ;; (lambda (opt name arg result) + ;; (alist-cons 'roll-back (or arg #f) result))) + + ;; (lambda (opt name arg result) + ;; (alist-cons 'roll-back (or arg "") result))) + (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile arg