[bug#42381] [PATCH 0/3] 'reconfigure' disallows downgrades by default

[bug#42381] [PATCH 0/3] 'reconfigure' disallows downgrades by default

[Ludovic Courtès]

Hello!

This patch series changes ‘guix system reconfigure’ so that it errors
out when attempting to downgrade the system, which could (re)introduce
security vulnerability and/or cause problems with stateful services
(we experienced the latter a couple of weeks ago on berlin.guix.gnu.org
actually).  Having this sanity check is pretty much a prerequisite for
unattended upgrades IMO (patch coming soon!).

It works by comparing the commits shown by ‘guix describe’ to those
shown by ‘guix system describe’, essentially.  Apart from that, it
is similar to what ‘guix pull’ does.  There’s a bit of redundancy
with code in ‘guix pull’, but that seemed unavoidable (it’s mostly
UI stuff).

Thoughts?

Thanks,
Ludo’.

Ludovic Courtès (3):
  git: Factorize 'resolve-reference'.
  git: 'update-cached-checkout' has a new #:check-out? parameter.
  guix system: 'reconfigure' disallows downgrades by default.

 doc/guix.texi                       | 35 +++++++++--
 guix/git.scm                        | 90 ++++++++++++++------------
 guix/scripts/system.scm             | 15 ++++-
 guix/scripts/system/reconfigure.scm | 97 ++++++++++++++++++++++++++++-
 4 files changed, 192 insertions(+), 45 deletions(-)

-- 
2.27.0

[bug#42381] [PATCH 1/3] git: Factorize 'resolve-reference'.

[Ludovic Courtès]

* guix/git.scm (resolve-reference): New procedure.
(switch-to-ref): Use it.
---
 guix/git.scm | 79 ++++++++++++++++++++++++++++------------------------
 1 file changed, 42 insertions(+), 37 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 19c1cb59d3..ca67b1d37c 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -150,47 +150,52 @@ of SHA1 string."
     (last (string-split url #\/)) ".git" "")
    "-" (string-take sha1 7)))
 
+(define (resolve-reference repository ref)
+  "Resolve the branch, commit or tag specified by REF, and return the
+corresponding Git object."
+  (let resolve ((ref ref))
+    (match ref
+      (('branch . branch)
+       (let ((oid (reference-target
+                   (branch-lookup repository branch BRANCH-REMOTE))))
+         (object-lookup repository oid)))
+      (('commit . commit)
+       (let ((len (string-length commit)))
+         ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
+         ;; can't be sure it's available.  Furthermore, 'string->oid' used to
+         ;; read out-of-bounds when passed a string shorter than 40 chars,
+         ;; which is why we delay calls to it below.
+         (if (< len 40)
+             (if (module-defined? (resolve-interface '(git object))
+                                  'object-lookup-prefix)
+                 (object-lookup-prefix repository (string->oid commit) len)
+                 (raise (condition
+                         (&message
+                          (message "long Git object ID is required")))))
+             (object-lookup repository (string->oid commit)))))
+      (('tag-or-commit . str)
+       (if (or (> (string-length str) 40)
+               (not (string-every char-set:hex-digit str)))
+           (resolve `(tag . ,str))              ;definitely a tag
+           (catch 'git-error
+             (lambda ()
+               (resolve `(tag . ,str)))
+             (lambda _
+               ;; There's no such tag, so it must be a commit ID.
+               (resolve `(commit . ,str))))))
+      (('tag    . tag)
+       (let ((oid (reference-name->oid repository
+                                       (string-append "refs/tags/" tag))))
+         ;; OID may point to a "tag" object, but it can also point directly
+         ;; to a "commit" object, as surprising as it may seem.  Return that
+         ;; object, whatever that is.
+         (object-lookup repository oid))))))
+
 (define (switch-to-ref repository ref)
   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 OID (roughly the commit hash) corresponding to REF."
   (define obj
-    (let resolve ((ref ref))
-      (match ref
-        (('branch . branch)
-         (let ((oid (reference-target
-                     (branch-lookup repository branch BRANCH-REMOTE))))
-           (object-lookup repository oid)))
-        (('commit . commit)
-         (let ((len (string-length commit)))
-           ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
-           ;; can't be sure it's available.  Furthermore, 'string->oid' used to
-           ;; read out-of-bounds when passed a string shorter than 40 chars,
-           ;; which is why we delay calls to it below.
-           (if (< len 40)
-               (if (module-defined? (resolve-interface '(git object))
-                                    'object-lookup-prefix)
-                   (object-lookup-prefix repository (string->oid commit) len)
-                   (raise (condition
-                           (&message
-                            (message "long Git object ID is required")))))
-               (object-lookup repository (string->oid commit)))))
-        (('tag-or-commit . str)
-         (if (or (> (string-length str) 40)
-                 (not (string-every char-set:hex-digit str)))
-             (resolve `(tag . ,str))              ;definitely a tag
-             (catch 'git-error
-               (lambda ()
-                 (resolve `(tag . ,str)))
-               (lambda _
-                 ;; There's no such tag, so it must be a commit ID.
-                 (resolve `(commit . ,str))))))
-        (('tag    . tag)
-         (let ((oid (reference-name->oid repository
-                                         (string-append "refs/tags/" tag))))
-           ;; OID may point to a "tag" object, but it can also point directly
-           ;; to a "commit" object, as surprising as it may seem.  Return that
-           ;; object, whatever that is.
-           (object-lookup repository oid))))))
+    (resolve-reference repository ref))
 
   (reset repository obj RESET_HARD)
   (object-id obj))
-- 
2.27.0

[bug#42381] [PATCH 2/3] git: 'update-cached-checkout' has a new #:check-out? parameter.

[Ludovic Courtès]

* guix/git.scm (update-cached-checkout): Add #:check-out? parameter and
honor it.
---
 guix/git.scm | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index ca67b1d37c..7f8f9addfb 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -292,6 +292,7 @@ definitely available in REPOSITORY, false otherwise."
                                  #:key
                                  (ref '(branch . "master"))
                                  recursive?
+                                 (check-out? #t)
                                  starting-commit
                                  (log-port (%make-void-port "w"))
                                  (cache-directory
@@ -306,7 +307,10 @@ provided) as returned by 'commit-relation'.
 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
 
-When RECURSIVE? is true, check out submodules as well, if any."
+When RECURSIVE? is true, check out submodules as well, if any.
+
+When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
+it unchanged."
   (define canonical-ref
     ;; We used to require callers to specify "origin/" for each branch, which
     ;; made little sense since the cache should be transparent to them.  So
@@ -337,7 +341,10 @@ When RECURSIVE? is true, check out submodules as well, if any."
 
      ;; Note: call 'commit-relation' from here because it's more efficient
      ;; than letting users re-open the checkout later on.
-     (let* ((oid      (switch-to-ref repository canonical-ref))
+     (let* ((oid      (if check-out?
+                          (switch-to-ref repository canonical-ref)
+                          (object-id
+                           (resolve-reference repository canonical-ref))))
             (new      (and starting-commit
                            (commit-lookup repository oid)))
             (old      (and starting-commit
-- 
2.27.0

[bug#42381] [PATCH 3/3] guix system: 'reconfigure' disallows downgrades by default.

[Ludovic Courtès]

This is similar to what 9744cc7b4636fafb772c94adb8f05961b5b39f16 did for
'guix pull'.

* guix/scripts/system/reconfigure.scm (ensure-forward-reconfigure)
(warn-about-backward-reconfigure, channel-relations)
(check-forward-update): New procedures.
* guix/scripts/system.scm (perform-action): Add #:validate-reconfigure.
Call 'check-forward-update' when ACTION is 'reconfigure.
(%options, show-help): Add "--allow-downgrades".
(%default-options): Add 'validate-reconfigure' key.
(process-action): Pass #:validate-reconfigure to 'perform-action'.
* doc/guix.texi (Invoking guix system): Document 'guix system describe'
more prominently, and document '--allow-downgrades'.
---
 doc/guix.texi                       | 35 +++++++++--
 guix/scripts/system.scm             | 15 ++++-
 guix/scripts/system/reconfigure.scm | 97 ++++++++++++++++++++++++++++-
 3 files changed, 141 insertions(+), 6 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 17338ed764..4398e533d2 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -27677,11 +27677,16 @@ an older system generation at boot time should you need it.
 Upon completion, the new system is deployed under
 @file{/run/current-system}.  This directory contains @dfn{provenance
 meta-data}: the list of channels in use (@pxref{Channels}) and
-@var{file} itself, when available.  This information is useful should
-you later want to inspect how this particular generation was built.
+@var{file} itself, when available.  You can view it by running:
 
-In fact, assuming @var{file} is self-contained, you can later rebuild
-generation @var{n} of your operating system with:
+@example
+guix system describe
+@end example
+
+This information is useful should you later want to inspect how this
+particular generation was built.  In fact, assuming @var{file} is
+self-contained, you can later rebuild generation @var{n} of your
+operating system with:
 
 @example
 guix time-machine \
@@ -27695,6 +27700,12 @@ system is not just a binary artifact: @emph{it carries its own source}.
 @xref{Service Reference, @code{provenance-service-type}}, for more
 information on provenance tracking.
 
+By default, @command{reconfigure} @emph{prevents you from downgrading
+your system}, which could (re)introduce security vulnerabilities and
+also cause problems with ``stateful'' services such as database
+management systems.  You can override that behavior by passing
+@option{--allow-downgrades}.
+
 @item switch-generation
 @cindex generations
 Switch to an existing system generation.  This action atomically
@@ -28021,6 +28032,22 @@ appear in the @code{operating-system} declaration actually exist
 needed at boot time are listed in @code{initrd-modules} (@pxref{Initial
 RAM Disk}).  Passing this option skips these tests altogether.
 
+@item --allow-downgrades
+Instruct @command{guix system reconfigure} to allow system downgrades.
+
+By default, @command{reconfigure} prevents you from downgrading your
+system.  It achieves that by comparing the provenance info of your
+system (shown by @command{guix system describe}) with that of your
+@command{guix} command (shown by @command{guix describe}).  If the
+commits for @command{guix} are not descendants of those used for your
+system, @command{guix system reconfigure} errors out.  Passing
+@option{--allow-downgrades} allows you to bypass these checks.
+
+@quotation Note
+Make sure you understand its security implications before using
+@option{--allow-downgrades}.
+@end quotation
+
 @cindex on-error
 @cindex on-error strategy
 @cindex error strategy
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f2b4367094..79bfcd7db2 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -736,6 +736,7 @@ and TARGET arguments."
 
 (define* (perform-action action os
                          #:key
+                         (validate-reconfigure ensure-forward-reconfigure)
                          save-provenance?
                          skip-safety-checks?
                          install-bootloader?
@@ -778,7 +779,8 @@ static checks."
          (operating-system-bootcfg os menu-entries)))
 
   (when (eq? action 'reconfigure)
-    (maybe-suggest-running-guix-pull))
+    (maybe-suggest-running-guix-pull)
+    (check-forward-update validate-reconfigure))
 
   ;; Check whether the declared file systems exist.  This is better than
   ;; instantiating a broken configuration.  Assume that we can only check if
@@ -926,6 +928,9 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
   -e, --expression=EXPR  consider the operating-system EXPR evaluates to
                          instead of reading FILE, when applicable"))
+  (display (G_ "
+      --allow-downgrades for 'reconfigure', allow downgrades to earlier
+                         channel revisions"))
   (display (G_ "
       --on-error=STRATEGY
                          apply STRATEGY (one of nothing-special, backtrace,
@@ -981,6 +986,11 @@ Some ACTIONS support additional ARGS.\n"))
          (option '(#\d "derivation") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'derivations-only? #t result)))
+         (option '("allow-downgrades") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'validate-reconfigure
+                               warn-about-backward-reconfigure
+                               result)))
          (option '("on-error") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'on-error (string->symbol arg)
@@ -1053,6 +1063,7 @@ Some ACTIONS support additional ARGS.\n"))
     (graft? . #t)
     (debug . 0)
     (verbosity . #f)                              ;default
+    (validate-reconfigure . ,ensure-forward-reconfigure)
     (file-system-type . "ext4")
     (image-size . guess)
     (install-bootloader? . #t)))
@@ -1138,6 +1149,8 @@ resulting from command-line parsing."
                                #:use-substitutes? (assoc-ref opts 'substitutes?)
                                #:skip-safety-checks?
                                (assoc-ref opts 'skip-safety-checks?)
+                               #:validate-reconfigure
+                               (assoc-ref opts 'validate-reconfigure)
                                #:file-system-type (assoc-ref opts 'file-system-type)
                                #:image-size (assoc-ref opts 'image-size)
                                #:full-boot? (assoc-ref opts 'full-boot?)
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 7885c33457..9013e035f7 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -34,9 +34,18 @@
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module ((guix self) #:select (make-config.scm))
+  #:autoload   (guix describe) (current-profile)
+  #:use-module (guix channels)
+  #:autoload   (guix git) (update-cached-checkout)
+  #:use-module (guix i18n)
+  #:use-module (guix diagnostics)
+  #:use-module ((guix utils) #:select (&fix-hint))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module ((guix config) #:select (%guix-package-name))
   #:export (switch-system-program
             switch-to-system
 
@@ -44,7 +53,11 @@
             upgrade-shepherd-services
 
             install-bootloader-program
-            install-bootloader))
+            install-bootloader
+
+            check-forward-update
+            ensure-forward-reconfigure
+            warn-about-backward-reconfigure))
 
 ;;; Commentary:
 ;;;
@@ -266,3 +279,85 @@ additional configurations specified by MENU-ENTRIES can be selected."
                                                             bootcfg-file
                                                             device
                                                             target))))))
+
+\f
+;;;
+;;; Downgrade detection.
+;;;
+
+(define (ensure-forward-reconfigure channel start commit relation)
+  "Raise an error if RELATION is not 'ancestor, meaning that START is not an
+ancestor of COMMIT, unless CHANNEL specifies a commit."
+  (match relation
+    ('ancestor #t)
+    ('self #t)
+    (_
+     (raise (make-compound-condition
+             (condition
+              (&message (message
+                         (format #f (G_ "\
+aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a")
+                                 commit (channel-name channel)
+                                 start)))
+              (&fix-hint
+               (hint (G_ "Use @option{--allow-downgrades} to force
+this downgrade.")))))))))
+
+(define (warn-about-backward-reconfigure channel start commit relation)
+  "Warn about non-forward updates of CHANNEL from START to COMMIT, without
+aborting."
+  (match relation
+    ((or 'ancestor 'self)
+     #t)
+    ('descendant
+     (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
+              (channel-name channel) start commit))
+    ('unrelated
+     (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
+              (channel-name channel) start commit))))
+
+(define (channel-relations old new)
+  "Return a list of channel/relation pairs, where each relation is a symbol as
+returned by 'commit-relation' denoting how commits of channels in OLD relate
+to commits of channels in NEW."
+  (filter-map (lambda (old)
+                (let ((new (find (lambda (channel)
+                                   (eq? (channel-name channel)
+                                        (channel-name old)))
+                                 new)))
+                  (and new
+                       (let-values (((checkout commit relation)
+                                     (update-cached-checkout
+                                      (channel-url new)
+                                      #:ref
+                                      `(commit . ,(channel-commit new))
+                                      #:starting-commit
+                                      (channel-commit old)
+                                      #:check-out? #f)))
+                         (list new
+                               (channel-commit old) (channel-commit new)
+                               relation)))))
+              old))
+
+(define* (check-forward-update #:optional
+                               (validate-reconfigure ensure-forward-reconfigure))
+  "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the
+currently-deployed commit (as returned by 'guix system describe') and the
+target commit (as returned by 'guix describe')."
+  ;; TODO: Make that functionality available to 'guix deploy'.
+  (define new
+    (or (and=> (current-profile) profile-channels)
+        '()))
+
+  (define old
+    (system-provenance "/run/current-system"))
+
+  (when (null? old)
+    (warning (G_ "cannot determine provenance for /run/current-system~%")))
+  (when (and (null? new) (not (getenv "GUIX_UNINSTALLED")))
+    (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name))
+
+  (for-each (match-lambda
+              ((channel old new relation)
+               (validate-reconfigure channel old new relation)))
+            (channel-relations old new)))
-- 
2.27.0

bug#42381: [PATCH 0/3] 'reconfigure' disallows downgrades by default

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

>   git: Factorize 'resolve-reference'.
>   git: 'update-cached-checkout' has a new #:check-out? parameter.
>   guix system: 'reconfigure' disallows downgrades by default.

Pushed as 8e31736b0a60919cc1bfc5dc22c395b09243484a.

Feedback welcome, in particular if it breaks your workflow.

Ludo’.