Merge branch 'master' into core-updates

doc/guix.texi

@@ -11991,8 +11991,9 @@ supported:
 @table @code
 @item reconfigure
 Build the operating system described in @var{file}, activate it, and
-switch to it@footnote{This action is usable only on systems already
+switch to it@footnote{This action (and the related actions
-running GuixSD.}.
+@code{switch-generation} and @code{roll-back}) are usable only on
+systems already running GuixSD.}.
 
 This effects all the configuration specified in @var{file}: user
 accounts, system services, global package list, setuid programs, etc.
@@ -12014,6 +12015,52 @@ guix pull}).  Failing to do that you would see an older version of Guix
 once @command{reconfigure} has completed.
 @end quotation
 
+@item switch-generation
+Switch to an existing system generation.  This action atomically
+switches the system profile to the specified system generation.  It also
+rearranges the system's existing GRUB menu entries.  It makes the menu
+entry for the specified system generation the default, and it moves the
+entries for the other generations to a submenu.  The next time the
+system boots, it will use the specified system generation.
+
+The target generation can be specified explicitly by its generation
+number.  For example, the following invocation would switch to system
+generation 7:
+
+@example
+guix system switch-generation 7
+@end example
+
+The target generation can also be specified relative to the current
+generation with the form @code{+N} or @code{-N}, where @code{+3} means
+``3 generations ahead of the current generation,'' and @code{-1} means
+``1 generation prior to the current generation.''  When specifying a
+negative value such as @code{-1}, you must precede it with @code{--} to
+prevent it from being parsed as an option.  For example:
+
+@example
+guix system switch-generation -- -1
+@end example
+
+Currently, the effect of invoking this action is @emph{only} to switch
+the system profile to an existing generation and rearrange the GRUB menu
+entries.  To actually start using the target system generation, you must
+reboot after running this action.  In the future, it will be updated to
+do the same things as @command{reconfigure}, like activating and
+deactivating services.
+
+This action will fail if the specified generation does not exist.
+
+@item roll-back
+Switch to the preceding system generation.  The next time the system
+boots, it will use the preceding system generation.  This is the inverse
+of @command{reconfigure}, and it is exactly the same as invoking
+@command{switch-generation} with an argument of @code{-1}.
+
+Currently, as with @command{switch-generation}, you must reboot after
+running this action to actually start using the preceding system
+generation.
+
 @item build
 Build the derivation of the operating system, which includes all the
 configuration files and programs needed to boot and run the system.

gnu/build/file-systems.scm

@@ -139,7 +139,7 @@ if DEVICE does not contain an ext2 file system."
 ;;;
 
 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
-;; <http://wiki.cryptsetup.googlecode.com/git/LUKS-standard/>.  We follow
+;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>.  We follow
 ;; version 1.2.1 of this document.
 
 (define-syntax %luks-endianness

gnu/build/install.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (install-grub
+            install-grub-config
             populate-root-file-system
             reset-timestamps
             register-closure
@@ -36,13 +38,24 @@
 ;;;
 ;;; Code:
 
-(define* (install-grub grub.cfg device mount-point)
+(define (install-grub grub.cfg device mount-point)
   "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
 MOUNT-POINT.
 
 Note that the caller must make sure that GRUB.CFG is registered as a GC root
 so that the fonts, background images, etc. referred to by GRUB.CFG are not
 GC'd."
+  (install-grub-config grub.cfg mount-point)
+  (unless (zero? (system* "grub-install" "--no-floppy"
+                          "--boot-directory"
+                          (string-append mount-point "/boot")
+                          device))
+    (error "failed to install GRUB")))
+
+(define (install-grub-config grub.cfg mount-point)
+  "Atomically copy GRUB.CFG into boot/grub/grub.cfg on the MOUNT-POINT.  Note
+that the caller must make sure that GRUB.CFG is registered as a GC root so
+that the fonts, background images, etc. referred to by GRUB.CFG are not GC'd."
   (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
          (pivot  (string-append target ".new")))
     (mkdir-p (dirname target))
@@ -50,13 +63,7 @@ GC'd."
     ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
     ;; work when /boot is on a separate partition.  Do that atomically.
     (copy-file grub.cfg pivot)
-    (rename-file pivot target)
+    (rename-file pivot target)))
-
-    (unless (zero? (system* "grub-install" "--no-floppy"
-                            "--boot-directory"
-                            (string-append mount-point "/boot")
-                            device))
-      (error "failed to install GRUB"))))
 
 (define (evaluate-populate-directive directive target)
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under

gnu/local.mk

@@ -614,7 +614,6 @@ dist_patch_DATA =						\
   %D%/packages/patches/ilmbase-fix-tests.patch			\
   %D%/packages/patches/inkscape-drop-wait-for-targets.patch	\
   %D%/packages/patches/isl-0.11.1-aarch64-support.patch	\
-  %D%/packages/patches/jansson-CVE-2016-4425.patch		\
   %D%/packages/patches/jbig2dec-ignore-testtest.patch		\
   %D%/packages/patches/jq-CVE-2015-8863.patch			\
   %D%/packages/patches/khmer-use-libraries.patch                \
@@ -690,7 +689,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/lua-pkgconfig.patch                      \
   %D%/packages/patches/lua51-liblua-so.patch                    \
   %D%/packages/patches/lua51-pkgconfig.patch                    \
-  %D%/packages/patches/lua52-liblua-so.patch                    \
+  %D%/packages/patches/lua-liblua-so.patch                      \
   %D%/packages/patches/luajit-no_ldconfig.patch			\
   %D%/packages/patches/luajit-symlinks.patch			\
   %D%/packages/patches/luit-posix.patch				\

gnu/packages/admin.scm

@@ -1570,14 +1570,14 @@ done with the @code{auditctl} utility.")
 (define-public nmap
   (package
     (name "nmap")
-    (version "7.12")
+    (version "7.31")
     (source (origin
               (method url-fetch)
               (uri (string-append "https://nmap.org/dist/nmap-" version
                                   ".tar.bz2"))
               (sha256
                (base32
-                "014vagh9ak10hidwzp9s6g30y5h5fhsh8wykcnc1hnn9hwm0ipv3"))
+                "0hiqb28950kn4bjsmw0ksfyss7j2qdmgrj3xsjf7073pq01lx7yb"))
               (modules '((guix build utils)))
               (snippet
                '(map delete-file-recursively
@@ -1603,6 +1603,12 @@ done with the @code{auditctl} utility.")
      '(#:configure-flags '("--without-zenmap")
        #:phases
        (modify-phases %standard-phases
+         (add-after 'configure 'patch-Makefile
+           (lambda _
+             (substitute* "Makefile"
+               ;; Do not attempt to build lua.
+               (("build-dnet build-lua") "build-dnet"))
+             #t))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (define (make out . args)

gnu/packages/game-development.scm

@@ -69,20 +69,25 @@
 (define-public bullet
   (package
     (name "bullet")
-    (version "2.82-r2704")
+    (version "2.85.1")
     (source (origin
               (method url-fetch)
-              (uri (string-append "https://bullet.googlecode.com/files/bullet-"
+              (uri (string-append "https://github.com/bulletphysics/bullet3/"
-                                  version ".tgz"))
+                                  "archive/" version ".tar.gz"))
+              (file-name (string-append name "-" version ".tar.gz"))
               (sha256
                (base32
-                "1lnfksxa9b1slyfcxys313ymsllvbsnxh9np06azkbgpfvmwkr37"))))
+                "0qpd37ws0xlxwy55dg058a5b4yw2jxiz09yyc3lc0frpa05pq5bf"))))
     (build-system cmake-build-system)
-    (arguments '(#:tests? #f ; no 'test' target
+    (arguments
-                 #:configure-flags (list
+     '(#:configure-flags (list (string-append
-                                    (string-append
+                                 "-DBUILD_SHARED_LIBS=ON "
-                                     "-DCMAKE_CXX_FLAGS=-fPIC "
+                                 "-DCMAKE_CXX_FLAGS=-fPIC "
-                                     (or (getenv "CXXFLAGS") "")))))
+                                 (or (getenv "CXXFLAGS") "")))))
+    (inputs
+     `(("glu" ,glu)
+       ("libx11" ,libx11)
+       ("mesa" ,mesa)))
     (home-page "http://bulletphysics.org/")
     (synopsis "3D physics engine library")
     (description

gnu/packages/games.scm

@@ -233,11 +233,12 @@ that beneath its ruins lay buried an ancient evil.")
     (source
      (origin
        (method url-fetch)
-       (uri (string-append "http://pingus.googlecode.com/files/pingus-"
+       (uri (string-append "https://github.com/Pingus/pingus/archive/v"
-                           version ".tar.bz2"))
+                           version ".tar.gz"))
+       (file-name (string-append name "-" version ".tar.gz"))
        (sha256
         (base32
-         "0q34d2k6anzqvb0mf67x85q92lfx9jr71ry13dlp47jx0x9i573m"))
+         "0r9v6as5vi7skvvy7b0fcaimhdlzmik64pyy68plgljhsghqkkf4"))
        (patches (search-patches "pingus-sdl-libs-config.patch"))))
     (build-system gnu-build-system)
     (native-inputs `(("pkg-config" ,pkg-config)

gnu/packages/ghostscript.scm

@@ -200,7 +200,8 @@ file format.  It also includes a C library that implements the graphics
 capabilities of the PostScript language.  It supports a wide variety of
 output file formats and printers.")
    (license license:agpl3+)
-   (home-page "http://www.gnu.org/software/ghostscript/")))
+   (home-page "http://www.gnu.org/software/ghostscript/")
+   (properties '((upstream-name . "gnu-ghostscript")))))
 
 (define-public ghostscript/x
   (package (inherit ghostscript)

gnu/packages/java.scm

@@ -1180,16 +1180,16 @@ an Ant task that extends the built-in @code{jar} task.")
     (version "1.3")
     (source (origin
               (method url-fetch)
-              (uri (string-append "https://hamcrest.googlecode.com/files/"
+              (uri (string-append "https://github.com/hamcrest/JavaHamcrest/"
-                                  "hamcrest-" version ".tgz"))
+                                  "archive/hamcrest-java-" version ".tar.gz"))
               (sha256
                (base32
-                "1hi0jv0zrgsf4l25aizxrgvxpsrmdklsmvw0jzwz7zv9s108whn6"))
+                "11g0s105fmwzijbv08lx8jlb521yravjmxnpgdx08fvg1kjivhva"))
               (modules '((guix build utils)))
               (snippet
                '(begin
-                  ;; Delete bundled jar archives.
+                  ;; Delete bundled thirds-party jar archives.
-                  (for-each delete-file (find-files "." "\\.jar$"))
+                  (delete-file-recursively "lib")
                   #t))))
     (build-system ant-build-system)
     (arguments
@@ -1237,6 +1237,12 @@ private Method[] allMethods = getSortedMethods();")))))
                 (string-append (assoc-ref inputs "java-qdox-1.12")
                                "/share/java/qdox.jar")))
              #t))
+         ;; build.xml searches for .jar files in this directoy, which
+         ;; we remove  from the source archive.
+         (add-before 'build 'create-dummy-directories
+           (lambda _
+             (mkdir-p "lib/integration")
+             #t))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (install-file (string-append "build/hamcrest-core-"

gnu/packages/lua.scm

@@ -40,15 +40,15 @@
 (define-public lua
   (package
     (name "lua")
-    (version "5.2.4")
+    (version "5.3.3")
     (source (origin
              (method url-fetch)
-             (uri (string-append "http://www.lua.org/ftp/lua-"
+             (uri (string-append "https://www.lua.org/ftp/lua-"
                                  version ".tar.gz"))
              (sha256
-              (base32 "0jwznq0l8qg9wh5grwg07b5cy3lzngvl5m2nl1ikp6vqssmf9qmr"))
+              (base32 "18mcfbbmjyp8f2l9yy7n6dzk066nq6man0kpwly4bppphilc04si"))
              (patches (search-patches "lua-pkgconfig.patch"
-                                      "lua52-liblua-so.patch"))))
+                                      "lua-liblua-so.patch"))))
     (build-system gnu-build-system)
     (inputs `(("readline" ,readline)))
     (arguments
@@ -69,7 +69,7 @@
                                (string-append "INSTALL_TOP=" out)
                                (string-append "INSTALL_MAN=" out
                                               "/share/man/man1")))))))))
-    (home-page "http://www.lua.org/")
+    (home-page "https://www.lua.org/")
     (synopsis "Embeddable scripting language")
     (description
      "Lua is a powerful, fast, lightweight, embeddable scripting language.  Lua
@@ -80,12 +80,25 @@ automatic memory management with incremental garbage collection, making it ideal
 for configuration, scripting, and rapid prototyping.")
     (license license:x11)))
 
+(define-public lua-5.2
+  (package (inherit lua)
+           (version "5.2.4")
+           (source
+            (origin
+              (method url-fetch)
+              (uri (string-append "https://www.lua.org/ftp/lua-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32 "0jwznq0l8qg9wh5grwg07b5cy3lzngvl5m2nl1ikp6vqssmf9qmr"))
+              (patches (search-patches "lua-pkgconfig.patch"
+                                       "lua-liblua-so.patch"))))))
+
 (define-public lua-5.1
   (package (inherit lua)
     (version "5.1.5")
     (source (origin
              (method url-fetch)
-             (uri (string-append "http://www.lua.org/ftp/lua-"
+             (uri (string-append "https://www.lua.org/ftp/lua-"
                                  version ".tar.gz"))
              (sha256
               (base32 "0cskd4w0g6rdm2q8q3i4n1h3j8kylhs3rq8mxwl9vwlmlxbgqh16"))

gnu/packages/networking.scm

@@ -487,7 +487,7 @@ which can be used to encrypt a password with @code{crypt(3)}.")
               ("libgcrypt" ,libgcrypt)
               ("libnl" ,libnl)
               ("libpcap" ,libpcap)
-              ("lua" ,lua)
+              ("lua" ,lua-5.2)
               ("krb5" ,mit-krb5)
               ("openssl" ,openssl)
               ("portaudio" ,portaudio)

gnu/packages/patches/lua-liblua-so.patch

@@ -1,3 +1,5 @@
+This applies to Lua 5.2 and 5.3.
+
 From 7a1b4e0829124976878ca2765a8e546667a92ceb Mon Sep 17 00:00:00 2001
 From: Leo Famulari <leo@famulari.name>
 Date: Fri, 30 Oct 2015 19:11:31 -0400

gnu/packages/python.scm

@@ -3922,6 +3922,141 @@ simple and Pythonic domain language.")
 (define-public python2-sqlalchemy
   (package-with-python2 python-sqlalchemy))
 
+(define-public python-pycodestyle
+  (package
+    (name "python-pycodestyle")
+    (version "2.0.0")
+    (source
+      (origin
+        (method url-fetch)
+        (uri (pypi-uri "pycodestyle" version))
+        (sha256
+          (base32
+            "1rz2v8506mdjdyxcnv9ygiw6v0d4dqx8z5sjyjm0w2v32h5l5w1p"))))
+    (build-system python-build-system)
+    (home-page "https://pycodestyle.readthedocs.io/")
+    (synopsis "Python style guide checker")
+    (description "@code{pycodestyle} (formerly pep8) is a tool to check
+Python code against some of the style conventions in
+@url{http://www.python.org/dev/peps/pep-0008/,PEP 8}.")
+    (license license:expat)
+    (properties `((python2-variant . ,(delay python2-pycodestyle))))))
+
+(define-public python2-pycodestyle
+  (let ((base (package-with-python2 (strip-python2-variant
+                                     python-pycodestyle))))
+    (package (inherit base)
+      (native-inputs
+       `(("python2-setuptools" ,python2-setuptools)
+         ,@(package-native-inputs base))))))
+
+(define-public python-orderedmultidict
+  (package
+    (name "python-orderedmultidict")
+    (version "0.7.10")
+    (source
+      (origin
+        (method url-fetch)
+        (uri (pypi-uri "orderedmultidict" version))
+        (sha256
+          (base32
+            "1gvqk0jd432wsn88kq4svad68xz3r012jfpnhh9in7bqrkyxidky"))))
+    (build-system python-build-system)
+    (arguments
+     `(#:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'fix-tests
+           (lambda _
+             ;; The package uses nosetest for running the tests.
+             ;; Adding this initfile allows to run the test suite
+             ;; without requiring nosetest.
+             (zero? (system* "touch" "tests/__init__.py")))))))
+    (propagated-inputs
+     `(("python-six" ,python-six)))
+    (native-inputs
+     `(("python-pycodestyle" ,python-pycodestyle)))
+    (home-page "https://github.com/gruns/orderedmultidict")
+    (synopsis "Python Ordered Multivalue Dictionary - omdict")
+    (description "This package contains a library for ordered multivalue
+dictionaries.  A multivalue dictionary is a dictionary that can store
+multiple values for the same key.  An ordered multivalue dictionary is a
+multivalue dictionary that retains the order of insertions and deletions.")
+    (license license:unlicense)
+    (properties `((python2-variant . ,(delay python2-orderedmultidict))))))
+
+(define-public python2-orderedmultidict
+  (let ((base (package-with-python2 (strip-python2-variant
+                                     python-orderedmultidict))))
+    (package (inherit base)
+      (native-inputs
+       `(("python2-setuptools" ,python2-setuptools)
+         ,@(package-native-inputs base))))))
+
+(define-public python-furl
+  (package
+    (name "python-furl")
+    (version "0.5.6")
+    (source
+      (origin
+        (method url-fetch)
+        (uri (pypi-uri "furl" version))
+        (sha256
+          (base32
+            "0lzpfpm686hvz3sr1mcrnd1b3lgmnw8v59gb43wfi98r3b671pqc"))))
+    (build-system python-build-system)
+    (propagated-inputs
+     `(("python-six" ,python-six)
+       ("python-orderedmultidict" ,python-orderedmultidict)))
+    (native-inputs
+     `(("python-pycodestyle" ,python-pycodestyle)))
+    (home-page "https://github.com/gruns/furl")
+    (synopsis "URL manipulation in Python")
+    (description "Furl provides an easy-to-use alternative to the
+@code{urllib} and @code{urlparse} modules for manipulating URLs.")
+    (license license:unlicense)
+    (properties `((python2-variant . ,(delay python2-furl))))))
+
+(define-public python2-furl
+  (let ((base (package-with-python2 (strip-python2-variant
+                                     python-furl))))
+    (package (inherit base)
+      (native-inputs
+       `(("python2-setuptools" ,python2-setuptools)
+         ,@(package-native-inputs base))))))
+
+(define-public python-flask-babel
+  (package
+    (name "python-flask-babel")
+    (version "0.11.1")
+    (source
+      (origin
+        (method url-fetch)
+        (uri (pypi-uri "Flask-Babel" version))
+        (sha256
+          (base32
+            "16b80cipdba9xj3jlaiaq6wgrgpjb70w3j01jjy9hbp4k71kd6yj"))))
+    (build-system python-build-system)
+    (propagated-inputs
+     `(("python-flask" ,python-flask)
+       ("python-babel" ,python-babel)
+       ("python-jinja2" ,python-jinja2)
+       ("python-pytz" ,python-pytz)))
+    (home-page "https://github.com/python-babel/flask-babel")
+    (synopsis "Add i18n/l10n support to Flask applications")
+    (description "This package implements internationalization and localization
+support for Flask.  This is based on the Python babel module as well as pytz -
+both of which are installed automatically if you install this library.")
+    (license license:bsd-3)
+    (properties `((python2-variant . ,(delay python2-flask-babel))))))
+
+(define-public python2-flask-babel
+  (let ((base (package-with-python2 (strip-python2-variant
+                                     python-flask-babel))))
+    (package (inherit base)
+      (native-inputs
+       `(("python2-setuptools" ,python2-setuptools)
+         ,@(package-native-inputs base))))))
+
 (define-public python-sqlalchemy-utils
   (package
     (name "python-sqlalchemy-utils")
@@ -3934,9 +4069,11 @@ simple and Pythonic domain language.")
          (base32
           "1zbmmh7n8m01ikizn2mj1mfwch26nsr1awv9mvskqry7av0mpy98"))))
     (build-system python-build-system)
-    (inputs
+    (propagated-inputs
      `(("python-six" ,python-six)
        ("python-sqlalchemy" ,python-sqlalchemy)))
+    (native-inputs
+     `(("python-pytest" ,python-pytest)))
     (home-page "https://github.com/kvesteri/sqlalchemy-utils")
     (synopsis "Various utility functions for SQLAlchemy")
     (description

gnu/packages/qt.scm

@@ -541,7 +541,11 @@ developers using C++ or QML, a CSS & JavaScript like language.")
                                  version ".tar.xz"))
              (sha256
               (base32
-               "1rb27x7i2pmvsck6wax2cg31gqpzaakciy45wm5l3lcl86j48czg"))))
+               "1rb27x7i2pmvsck6wax2cg31gqpzaakciy45wm5l3lcl86j48czg"))
+             (modules '((guix build utils)))
+             (snippet
+              '(begin
+                 (delete-file-recursively "src/3rdparty")))))
     (native-inputs `())
     (inputs
      `(("libmng" ,libmng)
@@ -677,7 +681,12 @@ developers using C++ or QML, a CSS & JavaScript like language.")
                                  version ".tar.xz"))
              (sha256
               (base32
-               "0ndmhiflmyr144nq8drd5njsdi282ixsm4730q5n0ji2v9dp1bh5"))))
+               "0ndmhiflmyr144nq8drd5njsdi282ixsm4730q5n0ji2v9dp1bh5"))
+             (modules '((guix build utils)))
+             (snippet
+              '(begin
+                 (delete-file-recursively
+                   "examples/multimedia/spectrum/3rdparty")))))
     (native-inputs
      `(("perl" ,perl)
        ("pkg-config" ,pkg-config)

gnu/packages/statistics.scm

@@ -514,7 +514,7 @@ panels or collapse high-dimensional arrays to simpler summary statistics.")
        (sha256
         (base32 "1l843p8vckjckdhgv37ngv47fga5jzy0n00pmipvp05nnaixk54j"))))
     (build-system r-build-system)
-    (home-page "http://r-proto.googlecode.com")
+    (home-page "https://github.com/hadley/proto")
     (synopsis "Prototype object-based programming")
     (description
      "Proto is an object oriented system using object-based, also called

gnu/packages/tls.scm

@@ -681,7 +681,7 @@ number generator")
 (define-public acme-client
   (package
     (name "acme-client")
-    (version "0.1.11")
+    (version "0.1.14")
     (source (origin
               (method url-fetch)
               (uri (string-append "https://kristaps.bsd.lv/" name "/"
@@ -689,7 +689,7 @@ number generator")
                                   version ".tgz"))
               (sha256
                (base32
-                "09pipyfk448gxqr7ci56gsq5la8wlydv7wwn9wk0zgjxmlh7h6fb"))))
+                "1qq4xk41pn65m3v7nnvkmxg96pr06vz6hzdrm0vcmlp3clzpbahl"))))
     (build-system gnu-build-system)
     (arguments
      '(#:tests? #f ; no test suite

gnu/packages/vim.scm

@@ -48,7 +48,7 @@
 (define-public vim
   (package
     (name "vim")
-    (version "8.0.0054")
+    (version "8.0.0069")
     (source (origin
              (method url-fetch)
              (uri (string-append "https://github.com/vim/vim/archive/v"
@@ -56,7 +56,7 @@
              (file-name (string-append name "-" version ".tar.gz"))
              (sha256
               (base32
-               "018my9vmvflww9yzrrzgdbja8j075yxqj0czg351r6wrndqiv9vq"))))
+               "1xxg0m296jqcg7wxxw1zcr0i10j1a85aw6ainpql2h4jrqbwqvy9"))))
     (build-system gnu-build-system)
     (arguments
      `(#:test-target "test"

gnu/packages/web.scm

@@ -236,7 +236,7 @@ and UNIX socket support.")
 (define-public jansson
   (package
     (name "jansson")
-    (version "2.7")
+    (version "2.9")
     (source (origin
              (method url-fetch)
              (uri
@@ -244,8 +244,7 @@ and UNIX socket support.")
                              version ".tar.gz"))
              (sha256
               (base32
-               "1mvq9p85khsl818i4vbszyfab0fd45mdrwrxjkzw05mk1xcyc1br"))
+               "19fjgfwjfj99rqa3kf96x5rssj88siazggksgrikd6h4r9sd1l0a"))))
-             (patches (search-patches "jansson-CVE-2016-4425.patch"))))
     (build-system gnu-build-system)
     (home-page "http://www.digip.org/jansson/")
     (synopsis "JSON C library")

gnu/system.scm

@@ -60,6 +60,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
   #:export (operating-system
             operating-system?
 
@@ -733,7 +734,7 @@ listed in OS.  The C library expects to find it under
                            (label label)
 
                            ;; The device where the kernel and initrd live.
-                           (device (file-system-device store-fs))
+                           (device (grub-device store-fs))
                            (device-mount-point
                             (file-system-mount-point store-fs))
 
@@ -748,6 +749,14 @@ listed in OS.  The C library expects to find it under
     (grub-configuration-file (operating-system-bootloader os) entries
                              #:old-entries old-entries)))
 
+(define (grub-device fs)
+  "Given FS, a <file-system> object, return a value suitable for use as the
+device in a <menu-entry>."
+  (case (file-system-title fs)
+    ((uuid) (file-system-device fs))
+    ((label) (file-system-device fs))
+    (else #f)))
+
 (define (operating-system-parameters-file os)
   "Return a file that describes the boot parameters of OS.  The primary use of
 this file is the reconstruction of GRUB menu entries for old configurations."
@@ -766,10 +775,7 @@ this file is the reconstruction of GRUB menu entries for old configurations."
                     #$(operating-system-kernel-arguments os))
                    (initrd #$initrd)
                    (store
-                    (device #$(case (file-system-title store)
+                    (device #$(grub-device store))
-                                ((uuid) (file-system-device store))
-                                ((label) (file-system-device store))
-                                (else #f)))
                     (mount-point #$(file-system-mount-point store))))
                 #:set-load-path? #f)))
 
@@ -831,7 +837,11 @@ this file is the reconstruction of GRUB menu entries for old configurations."
          (('store ('device device) _ ...)
           device)
          (_                                       ;the old format
-          root)))
+          ;; Root might be a device path like "/dev/sda1", which is not a
+          ;; suitable GRUB device identifier.
+          (if (string-prefix? "/" root)
+              #f
+              root))))
 
       (store-mount-point
        (match (assq 'store rest)

gnu/system/pam.scm

@@ -316,4 +316,4 @@ all the PAM services."
            (pam-configuration (services base)
                               (transform transform))))
 
-;;; linux.scm ends here
+

guix/profiles.scm

@@ -5,6 +5,7 @@
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -97,6 +98,7 @@
             generation-number
             generation-numbers
             profile-generations
+            relative-generation-spec->number
             relative-generation
             previous-generation-number
             generation-time
@@ -1048,6 +1050,23 @@ former profiles were found."
         '()
         generations)))
 
+(define (relative-generation-spec->number profile spec)
+  "Return PROFILE's generation specified by SPEC, which is a string.  The SPEC
+may be a N, -N, or +N, where N is a number.  If the spec is N, then the number
+returned is N.  If it is -N, then the number returned is the profile's current
+generation number minus N.  If it is +N, then the number returned is the
+profile's current generation number plus N.  Return #f if there is no such
+generation."
+  (let ((number (string->number spec)))
+    (and number
+         (case (string-ref spec 0)
+           ((#\+ #\-)
+            (relative-generation profile number))
+           (else (if (memv number (profile-generations profile))
+                     number
+                     #f))))))
+
+
 (define* (relative-generation profile shift #:optional
                               (current (generation-number profile)))
   "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.

guix/scripts/package.scm

@@ -5,6 +5,7 @@
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -782,12 +783,7 @@ processed, #f otherwise."
                                    #:key dry-run?)
   "Switch PROFILE to the generation specified by SPEC."
   (unless dry-run?
-    (let* ((number (string->number spec))
+    (let ((number (relative-generation-spec->number profile 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)))))

guix/scripts/system.scm

@@ -366,8 +366,10 @@ it atomically, and then run OS's activation script."
     (date->string (time-utc->date time)
                   "~Y-~m-~d ~H:~M")))
 
-(define* (previous-grub-entries #:optional (profile %system-profile))
+(define* (profile-grub-entries #:optional (profile %system-profile)
-  "Return a list of 'menu-entry' for the generations of PROFILE."
+                                  (numbers (generation-numbers profile)))
+  "Return a list of 'menu-entry' for the generations of PROFILE specified by
+NUMBERS, which is a list of generation numbers."
   (define (system->grub-entry system number time)
     (unless-file-not-found
      (let* ((file             (string-append system "/parameters"))
@@ -395,8 +397,7 @@ it atomically, and then run OS's activation script."
                 kernel-arguments))
         (initrd initrd)))))
 
-  (let* ((numbers (generation-numbers profile))
+  (let* ((systems (map (cut generation-file-name profile <>)
-         (systems (map (cut generation-file-name profile <>)
                        numbers))
          (times   (map (lambda (system)
                          (unless-file-not-found
@@ -404,6 +405,65 @@ it atomically, and then run OS's activation script."
                        systems)))
     (filter-map system->grub-entry systems numbers times)))
 
+
+;;;
+;;; Roll-back.
+;;;
+(define (roll-back-system store)
+  "Roll back the system profile to its previous generation.  STORE is an open
+connection to the store."
+  (switch-to-system-generation store "-1"))
+
+;;;
+;;; Switch generations.
+;;;
+(define (switch-to-system-generation store spec)
+  "Switch the system profile to the generation specified by SPEC, and
+re-install grub with a grub configuration file that uses the specified system
+generation as its default entry.  STORE is an open connection to the store."
+  (let ((number (relative-generation-spec->number %system-profile spec)))
+    (if number
+        (begin
+          (reinstall-grub store number)
+          (switch-to-generation* %system-profile number))
+        (leave (_ "cannot switch to system generation '~a'~%") spec))))
+
+(define (reinstall-grub store number)
+  "Re-install grub for existing system profile generation NUMBER.  STORE is an
+open connection to the store."
+  (let* ((generation (generation-file-name %system-profile number))
+         (file (string-append generation "/parameters"))
+         (params (unless-file-not-found
+                  (call-with-input-file file read-boot-parameters)))
+         (root-device (boot-parameters-root-device params))
+         ;; We don't currently keep track of past menu entries' details.  The
+         ;; default values will allow the system to boot, even if they differ
+         ;; from the actual past values for this generation's entry.
+         (grub-config (grub-configuration (device root-device)))
+         ;; Make the specified system generation the default entry.
+         (entries (profile-grub-entries %system-profile (list number)))
+         (old-generations (delv number (generation-numbers %system-profile)))
+         (old-entries (profile-grub-entries %system-profile old-generations))
+         (grub.cfg (run-with-store store
+                     (grub-configuration-file grub-config
+                                              entries
+                                              #:old-entries old-entries))))
+    (show-what-to-build store (list grub.cfg))
+    (build-derivations store (list grub.cfg))
+    ;; This is basically the same as install-grub*, but for now we avoid
+    ;; re-installing the GRUB boot loader itself onto a device, mainly because
+    ;; we don't in general have access to the same version of the GRUB package
+    ;; which was used when installing this other system generation.
+    (let* ((grub.cfg-path (derivation->output-path grub.cfg))
+           (gc-root (string-append %gc-roots-directory "/grub.cfg"))
+           (temp-gc-root (string-append gc-root ".new")))
+      (switch-symlinks temp-gc-root grub.cfg-path)
+      (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
+        (delete-file temp-gc-root)
+        (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
+               grub.cfg-path))
+      (rename-file temp-gc-root gc-root))))
+
 
 ;;;
 ;;; Graphs.
@@ -563,7 +623,7 @@ building anything."
                       (operating-system-grub.cfg os
                                                  (if (eq? 'init action)
                                                      '()
-                                                     (previous-grub-entries)))))
+                                                     (profile-grub-entries)))))
 
        ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if
        ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
@@ -640,13 +700,18 @@ building anything."
 ;;;
 
 (define (show-help)
-  (display (_ "Usage: guix system [OPTION] ACTION [FILE]
+  (display (_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE]
-Build the operating system declared in FILE according to ACTION.\n"))
+Build the operating system declared in FILE according to ACTION.
+Some ACTIONS support additional ARGS.\n"))
   (newline)
   (display (_ "The valid values for ACTION are:\n"))
   (newline)
   (display (_ "\
    reconfigure      switch to a new operating system configuration\n"))
+  (display (_ "\
+   roll-back        switch to the previous operating system configuration\n"))
+  (display (_ "\
+   switch-generation switch to an existing operating system configuration\n"))
   (display (_ "\
    list-generations list the system generations\n"))
   (display (_ "\
@@ -808,15 +873,33 @@ resulting from command-line parsing."
   "Process COMMAND, one of the 'guix system' sub-commands.  ARGS is its
 argument list and OPTS is the option alist."
   (case command
+    ;; The following commands do not need to use the store, and they do not need
+    ;; an operating system configuration file.
     ((list-generations)
-     ;; List generations.  No need to connect to the daemon, etc.
      (let ((pattern (match args
                       (() "")
                       ((pattern) pattern)
                       (x (leave (_ "wrong number of arguments~%"))))))
        (list-generations pattern)))
-    (else
+    ;; The following commands need to use the store, but they do not need an
-     (process-action command args opts))))
+    ;; operating system configuration file.
+    ((switch-generation)
+     (let ((pattern (match args
+                      ((pattern) pattern)
+                      (x (leave (_ "wrong number of arguments~%"))))))
+       (with-store store
+         (set-build-options-from-command-line store opts)
+         (switch-to-system-generation store pattern))))
+    ((roll-back)
+     (let ((pattern (match args
+                      (() "")
+                      (x (leave (_ "wrong number of arguments~%"))))))
+       (with-store store
+         (set-build-options-from-command-line store opts)
+         (roll-back-system store))))
+    ;; The following commands need to use the store, and they also
+    ;; need an operating system configuration file.
+    (else (process-action command args opts))))
 
 (define (guix-system . args)
   (define (parse-sub-command arg result)
@@ -826,7 +909,8 @@ argument list and OPTS is the option alist."
         (let ((action (string->symbol arg)))
           (case action
             ((build container vm vm-image disk-image reconfigure init
-              extension-graph shepherd-graph list-generations)
+              extension-graph shepherd-graph list-generations roll-back
+              switch-generation)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))