Merge branch 'master' into core-updates

14 files changed, 490 insertions, 72 deletions

diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm
new file mode 100644
index 0000000000..35edc0056d
--- /dev/null
+++ b/guix/build-system/renpy.scm
@@ -0,0 +1,131 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system renpy)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix memoization)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (%renpy-build-system-modules
+            default-renpy
+            renpy-build
+            renpy-build-system))
+
+(define (default-renpy)
+  "Return the default Ren'py package."
+  ;; Lazily resolve the binding to avoid a circular dependency.
+  (let ((module (resolve-interface '(gnu packages game-development))))
+    (module-ref module 'renpy)))
+
+(define %renpy-build-system-modules
+  ;; Build-side modules imported by default.
+  `((guix build renpy-build-system)
+    (guix build json)
+    (guix build python-build-system)
+    ,@%gnu-build-system-modules))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system target
+                (renpy (default-renpy))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:source #:target #:renpy #:inputs #:native-inputs))
+
+  (and (not target)                               ;XXX: no cross-compilation
+       (bag
+         (name name)
+         (system system)
+         (host-inputs `(,@(if source
+                              `(("source" ,source))
+                              '())
+                        ,@inputs
+
+                        ;; Keep the standard inputs of 'gnu-build-system'.
+                        ,@(standard-packages)))
+         (build-inputs `(("renpy" ,renpy)
+                         ,@native-inputs))
+         (outputs outputs)
+         (build renpy-build)
+         (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (renpy-build store name inputs
+                       #:key
+                       (phases '(@ (guix build renpy-build-system)
+                                   %standard-phases))
+                       (configure-flags ''())
+                       (outputs '("out"))
+                       (output "out")
+                       (game "game")
+                       (search-paths '())
+                       (system (%current-system))
+                       (guile #f)
+                       (imported-modules %renpy-build-system-modules)
+                       (modules '((guix build renpy-build-system)
+                                  (guix build utils))))
+  "Build SOURCE using RENPY, and with INPUTS."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (renpy-build #:name ,name
+                    #:source ,(match (assoc-ref inputs "source")
+                                (((? derivation? source))
+                                 (derivation->output-path source))
+                                ((source)
+                                 source)
+                                (source
+                                 source))
+                     #:configure-flags ,configure-flags
+                     #:system ,system
+                     #:phases ,phases
+                     #:outputs %outputs
+                     #:output ,output
+                     #:game ,game
+                     #:search-paths ',(map search-path-specification->sexp
+                                           search-paths)
+                     #:inputs %build-inputs)))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                                         ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:inputs inputs
+                                #:system system
+                                #:modules imported-modules
+                                #:outputs outputs
+                                #:guile-for-build guile-for-build))
+
+(define renpy-build-system
+  (build-system
+    (name 'renpy)
+    (description "The Ren'py build system")
+    (lower lower)))
diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm
new file mode 100644
index 0000000000..464fc97b13
--- /dev/null
+++ b/guix/build/renpy-build-system.scm
@@ -0,0 +1,99 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build renpy-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module ((guix build python-build-system) #:prefix python:)
+  #:use-module (guix build json)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (%standard-phases
+            renpy-build))
+
+(define* (build #:key game #:allow-other-keys)
+  (for-each make-file-writable
+            (find-files game (lambda (pred stat)
+                               (eq? (stat:type stat) 'directory))))
+  (invoke "renpy"
+          "--json-dump" (string-append game "/renpy-build.json")
+          game
+          ;; should be "compile", but renpy wants to compile itself really
+          ;; badly if we do
+          "quit")
+  #t)
+
+(define* (install #:key outputs game (output "out") #:allow-other-keys)
+  (let* ((out (assoc-ref outputs output))
+         (json-dump (call-with-input-file (string-append game
+                                                         "/renpy-build.json")
+                      read-json))
+         (build (assoc-ref json-dump "build"))
+         (executable-name (assoc-ref build "executable_name"))
+         (directory-name (assoc-ref build "directory_name")))
+    (let ((launcher (string-append out "/bin/" executable-name))
+          (data (string-append out "/share/renpy/" directory-name)))
+      (mkdir-p (string-append out "/bin"))
+      (copy-recursively game data)
+      ;; We don't actually want the metadata to be dumped in the output
+      ;; directory
+      (delete-file (string-append data "/renpy-build.json"))
+      (call-with-output-file launcher
+        (lambda (port)
+          (format port "#!~a~%~a ~a \"$@\""
+                  (which "bash")
+                  (which "renpy")
+                  data)))
+      (chmod launcher #o755)))
+  #t)
+
+(define* (install-desktop-file #:key outputs game (output "out")
+                               #:allow-other-keys)
+  (let* ((out (assoc-ref outputs output))
+         (json-dump (call-with-input-file (string-append game
+                                                         "/renpy-build.json")
+                      read-json))
+         (build (assoc-ref json-dump "build"))
+         (directory-name (assoc-ref build "directory_name"))
+         (executable-name (assoc-ref build "executable_name")))
+    (make-desktop-entry-file
+     (string-append out "/share/applications/" executable-name ".desktop")
+     #:name (assoc-ref json-dump "name")
+     #:generic-name (assoc-ref build "display_name")
+     #:exec (string-append (which "renpy") " "
+                           out "/share/renpy/" directory-name)
+     #:categories '("Game" "Visual Novel")))
+  #t)
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (add-after 'unpack 'enable-bytecode-determinism
+      (assoc-ref python:%standard-phases 'enable-bytecode-determinism))
+    (delete 'bootstrap)
+    (delete 'configure)
+    (replace 'build build)
+    (delete 'check)
+    (replace 'install install)
+    (add-after 'install 'install-desktop-file install-desktop-file)))
+
+(define* (renpy-build #:key inputs (phases %standard-phases)
+                       #:allow-other-keys #:rest args)
+  "Build the given Ren'py package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
diff --git a/guix/channels.scm b/guix/channels.scm
index e7e1eb6fd0..05226e766b 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -47,6 +47,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:autoload   (guix describe) (current-channels) ;XXX: circular dep
   #:autoload   (guix self) (whole-package make-config.scm)
   #:autoload   (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
   #:autoload   (guix quirks) (%quirks %patches applicable-patch? apply-patch)
@@ -344,6 +345,18 @@ commits)...~%")
 
     (progress-reporter/bar (length commits)))
 
+  (define authentic-commits
+    ;; Consider the currently-used commit of CHANNEL as authentic so
+    ;; authentication can skip it and all its closure.
+    (match (find (lambda (candidate)
+                   (eq? (channel-name candidate) (channel-name channel)))
+                 (current-channels))
+      (#f '())
+      (channel
+       (if (channel-commit channel)
+           (list (channel-commit channel))
+           '()))))
+
   ;; XXX: Too bad we need to re-open CHECKOUT.
   (with-repository checkout repository
     (authenticate-repository repository
@@ -354,6 +367,7 @@ commits)...~%")
                              #:keyring-reference
                              (string-append keyring-reference-prefix
                                             keyring-reference)
+                             #:authentic-commits authentic-commits
                              #:make-reporter make-reporter
                              #:cache-key cache-key)))
 
@@ -626,16 +640,23 @@ that unconditionally resumes the continuation."
       (values (run-with-store store mvalue)
               store))))
 
-(define* (build-from-source name source
-                            #:key core verbose? commit
-                            (dependencies '()))
-  "Return a derivation to build Guix from SOURCE, using the self-build script
-contained therein; use COMMIT as the version string.  When CORE is true, build
-package modules under SOURCE using CORE, an instance of Guix."
+(define* (build-from-source instance
+                            #:key core verbose? (dependencies '()))
+  "Return a derivation to build Guix from INSTANCE, using the self-build
+script contained therein.  When CORE is true, build package modules under
+SOURCE using CORE, an instance of Guix."
+  (define name
+    (symbol->string
+     (channel-name (channel-instance-channel instance))))
+  (define source
+    (channel-instance-checkout instance))
+  (define commit
+    (channel-instance-commit instance))
+
   ;; Running the self-build script makes it easier to update the build
   ;; procedure: the self-build script of the Guix-to-be-installed contains the
   ;; right dependencies, build procedure, etc., which the Guix-in-use may not
-  ;; be know.
+  ;; know.
   (define script
     (string-append source "/" %self-build-file))
 
@@ -661,7 +682,9 @@ package modules under SOURCE using CORE, an instance of Guix."
           ;; cause us to redo half of the BUILD computation several times just
           ;; to realize it gives the same result.
           (with-trivial-build-handler
-           (build source #:verbose? verbose? #:version commit
+           (build source
+                  #:verbose? verbose? #:version commit
+                  #:channel-metadata (channel-instance->sexp instance)
                   #:pull-version %pull-version))))
 
       ;; Build a set of modules that extend Guix using the standard method.
@@ -672,10 +695,7 @@ package modules under SOURCE using CORE, an instance of Guix."
   "Return, as a monadic value, the derivation for INSTANCE, a channel
 instance.  DEPENDENCIES is a list of extensions providing Guile modules that
 INSTANCE depends on."
-  (build-from-source (symbol->string
-                      (channel-name (channel-instance-channel instance)))
-                     (channel-instance-checkout instance)
-                     #:commit (channel-instance-commit instance)
+  (build-from-source instance
                      #:core core
                      #:dependencies dependencies))
 
diff --git a/guix/config.scm.in b/guix/config.scm.in
index b2901735d8..d582d91d74 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -23,6 +23,8 @@
             %guix-bug-report-address
             %guix-home-page-url
 
+            %channel-metadata
+
             %storedir
             %localstatedir
             %sysconfdir
@@ -56,6 +58,27 @@
 (define %guix-home-page-url
   "@PACKAGE_URL@")
 
+(define %channel-metadata
+  ;; When true, this is an sexp containing metadata for the 'guix' channel
+  ;; this file was built from.  This is used by (guix describe).
+  (let ((url    @GUIX_CHANNEL_URL@)
+        (commit @GUIX_CHANNEL_COMMIT@)
+        (intro  @GUIX_CHANNEL_INTRODUCTION@))
+    (and url commit
+         `(repository
+           (version 0)
+           (url ,url)
+           (branch "master")                      ;XXX: doesn't really matter
+           (commit ,commit)
+           (name guix)
+           ,@(if intro
+                 `((introduction
+                    (channel-introduction
+                     (version 0)
+                     (commit ,(car intro))
+                     (signer ,(cdr intro)))))
+                 '())))))
+
 (define %storedir
   "@storedir@")
 
diff --git a/guix/describe.scm b/guix/describe.scm
index ac89fc0d7c..6a31c707f0 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -23,12 +23,13 @@
   #:use-module ((guix utils) #:select (location-file))
   #:use-module ((guix store) #:select (%store-prefix store-path?))
   #:use-module ((guix config) #:select (%state-directory))
-  #:autoload   (guix channels) (sexp->channel)
+  #:autoload   (guix channels) (sexp->channel manifest-entry-channel)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (current-profile
             current-profile-date
             current-profile-entries
+            current-channels
             package-path-entries
 
             package-provenance
@@ -87,10 +88,19 @@ as a number of seconds since the Epoch, or #f if it could not be determined."
                            (string-append (dirname file) "/" target)))))
              (const #f)))))))
 
+(define (channel-metadata)
+  "Return the 'guix' channel metadata sexp from (guix config) if available;
+otherwise return #f."
+  ;; Older 'build-self.scm' would create a (guix config) file without the
+  ;; '%channel-metadata' variable.  Thus, properly deal with a lack of
+  ;; information.
+  (let ((module (resolve-interface '(guix config))))
+    (and=> (module-variable module '%channel-metadata) variable-ref)))
+
 (define current-profile-entries
   (mlambda ()
     "Return the list of entries in the 'guix pull' profile the calling process
-lives in, or #f if this is not applicable."
+lives in, or the empty list if this is not applicable."
     (match (current-profile)
       (#f '())
       (profile
@@ -105,6 +115,20 @@ lives in, or #f if this is not applicable."
               (string=? (manifest-entry-name entry) "guix"))
             (current-profile-entries))))
 
+(define current-channels
+  (mlambda ()
+    "Return the list of channels currently available, including the 'guix'
+channel.  Return the empty list if this information is missing."
+    (match (current-profile-entries)
+      (()
+       ;; As a fallback, if we're not running from a profile, use 'guix'
+       ;; channel metadata from (guix config).
+       (match (channel-metadata)
+         (#f '())
+         (sexp (or (and=> (sexp->channel sexp 'guix) list) '()))))
+      (entries
+       (filter-map manifest-entry-channel entries)))))
+
 (define (package-path-entries)
   "Return two values: the list of package path entries to be added to the
 package search path, and the list to be added to %LOAD-COMPILED-PATH.  These
diff --git a/guix/docker.scm b/guix/docker.scm
index 97ac6d982b..889aaeacb5 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -113,7 +113,14 @@ Return a version of TAG that follows these rules."
 (define %tar-determinism-options
   ;; GNU tar options to produce archives deterministically.
   '("--sort=name" "--mtime=@1"
-    "--owner=root:0" "--group=root:0"))
+    "--owner=root:0" "--group=root:0"
+
+    ;; When 'build-docker-image' is passed store items, the 'nlink' of the
+    ;; files therein leads tar to store hard links instead of actual copies.
+    ;; However, the 'nlink' count depends on deduplication in the store; it's
+    ;; an "implicit input" to the build process.  '--hard-dereference'
+    ;; eliminates it.
+    "--hard-dereference"))
 
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm
index 4ab5419bd6..ab3fcd8b2f 100644
--- a/guix/git-authenticate.scm
+++ b/guix/git-authenticate.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -376,12 +376,14 @@ instead of '~a'")
                                   (cache-key (repository-cache-key repository))
                                   (end (reference-target
                                         (repository-head repository)))
+                                  (authentic-commits '())
                                   (historical-authorizations '())
                                   (make-reporter
                                    (const progress-reporter/silent)))
   "Authenticate REPOSITORY up to commit END, an OID.  Authentication starts
 with commit START, an OID, which must be signed by SIGNER; an exception is
-raised if that is not the case.  Return an alist mapping OpenPGP public keys
+raised if that is not the case.  Commits listed in AUTHENTIC-COMMITS and their
+closure are considered authentic.  Return an alist mapping OpenPGP public keys
 to the number of commits signed by that key that have been traversed.
 
 The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY, where
@@ -404,7 +406,8 @@ denoting the authorized keys for commits whose parent lack the
     (filter-map (lambda (id)
                   (false-if-git-not-found
                    (commit-lookup repository (string->oid id))))
-                (previously-authenticated-commits cache-key)))
+                (append (previously-authenticated-commits cache-key)
+                        authentic-commits)))
 
   (define commits
     ;; Commits to authenticate, excluding the closure of
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 34cba35401..c9ea9f2e29 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -112,6 +113,13 @@ procedure, but both the category and synopsis are meant to be read (parsed) by
          doc
          body ...)))))
 
+(define (option-hint guess options)
+  "Return the closest long-name OPTIONS from GUESS,
+according to'string-distance'."
+  (define (options->long-names options)
+    (filter string? (append-map option-names options)))
+  (string-closest guess (options->long-names options) #:threshold 3))
+
 (define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
 reporting."
@@ -149,7 +157,12 @@ parameter of 'args-fold'."
     ;; Actual parsing takes place here.
     (apply args-fold* args options
            (lambda (opt name arg . rest)
-             (leave (G_ "~A: unrecognized option~%") name))
+             (let ((hint (option-hint name options)))
+               (report-error (G_ "~A: unrecognized option~%") name)
+               (when hint
+                 (display-hint
+                  (format #f (G_ "Did you mean @code{~a}?~%") hint)))
+               (exit 1)))
            argument-handler
            seeds))
 
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index e47d207ee0..6f8d9aceec 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -182,20 +182,18 @@ string is ~a.~%")
                           (current-output-port))))
     (display-package-search-path fmt)))
 
-(define (display-profile-info profile fmt)
+(define* (display-profile-info profile fmt
+                               #:optional
+                               (channels (profile-channels profile)))
   "Display information about PROFILE, a profile as created by (guix channels),
-in the format specified by FMT."
+in the format specified by FMT.  PROFILE can be #f, in which case CHANNELS is
+what matters."
   (define number
-    (generation-number profile))
-
-  (define channels
-    (profile-channels (if (zero? number)
-                          profile
-                          (generation-file-name profile number))))
+    (and profile (generation-number profile)))
 
   (match fmt
     ('human
-     (display-profile-content profile number))
+     (display-profile-content profile number channels))
     ('channels
      (pretty-print `(list ,@(map channel->code channels))))
     ('channels-sans-intro
@@ -213,33 +211,37 @@ in the format specified by FMT."
                   channels))))
   (display-package-search-path fmt))
 
-(define (display-profile-content profile number)
-  "Display the packages in PROFILE, generation NUMBER, in a human-readable
-way and displaying details about the channel's source code."
-  (display-generation profile number)
-  (for-each (lambda (entry)
-              (format #t "  ~a ~a~%"
-                      (manifest-entry-name entry)
-                      (manifest-entry-version entry))
-              (match (manifest-entry-channel entry)
-                ((? channel? channel)
-                 (format #t (G_ "    repository URL: ~a~%")
-                         (channel-url channel))
-                 (when (channel-branch channel)
-                   (format #t (G_ "    branch: ~a~%")
-                           (channel-branch channel)))
-                 (format #t (G_ "    commit: ~a~%")
-                         (if (supports-hyperlinks?)
-                             (channel-commit-hyperlink channel)
-                             (channel-commit channel))))
-                (_ #f)))
+(define (profile-generation-channels profile number)
+  "Return the list of channels for generation NUMBER of PROFILE."
+  (profile-channels (if (zero? number)
+                        profile
+                        (generation-file-name profile number))))
 
-            ;; Show most recently installed packages last.
-            (reverse
-             (manifest-entries
-              (profile-manifest (if (zero? number)
-                                    profile
-                                    (generation-file-name profile number)))))))
+(define* (display-profile-content profile number
+                                  #:optional
+                                  (channels
+                                   (profile-generation-channels profile
+                                                                number)))
+  "Display CHANNELS along with PROFILE info, generation NUMBER, in a
+human-readable way and displaying details about the channel's source code.
+PROFILE and NUMBER "
+  (when (and number profile)
+    (display-generation profile number))
+
+  (for-each (lambda (channel)
+              (format #t "  ~a ~a~%"
+                      (channel-name channel)
+                      (string-take (channel-commit channel) 7))
+              (format #t (G_ "    repository URL: ~a~%")
+                      (channel-url channel))
+              (when (channel-branch channel)
+                (format #t (G_ "    branch: ~a~%")
+                        (channel-branch channel)))
+              (format #t (G_ "    commit: ~a~%")
+                      (if (supports-hyperlinks?)
+                          (channel-commit-hyperlink channel)
+                          (channel-commit channel))))
+            channels))
 
 (define %vcs-web-views
   ;; Hard-coded list of host names and corresponding web view URL templates.
@@ -295,6 +297,10 @@ text.  The hyperlink links to a web view of COMMIT, when available."
     (with-error-handling
       (match profile
         (#f
-         (display-checkout-info format))
+         (match (current-channels)
+           (()
+            (display-checkout-info format))
+           (channels
+            (display-profile-info #f format channels))))
         (profile
          (display-profile-info (canonicalize-profile profile) format))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index f4d12f89bf..a39347743e 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -21,6 +21,7 @@
 (define-module (guix scripts environment)
   #:use-module (guix ui)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix grafts)
   #:use-module (guix derivations)
@@ -137,6 +138,8 @@ COMMAND or an interactive shell in that environment.\n"))
   (display (G_ "
   -m, --manifest=FILE    create environment with the manifest from FILE"))
   (display (G_ "
+  -p, --profile=PATH     create environment from profile at PATH"))
+  (display (G_ "
       --ad-hoc           include all specified packages in the environment instead
                          of only their inputs"))
   (display (G_ "
@@ -269,6 +272,10 @@ use '--preserve' instead~%"))
          (option '(#\P "link-profile") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'link-profile? #t result)))
+         (option '(#\p "profile") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'profile arg
+                               (alist-delete 'profile result eq?))))
          (option '(#\u "user") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'user arg
@@ -706,6 +713,7 @@ message if any test fails."
            (user       (assoc-ref opts 'user))
            (bootstrap? (assoc-ref opts 'bootstrap?))
            (system     (assoc-ref opts 'system))
+           (profile    (assoc-ref opts 'profile))
            (command    (or (assoc-ref opts 'exec)
                            ;; Spawn a shell if the user didn't specify
                            ;; anything in particular.
@@ -735,8 +743,16 @@ message if any test fails."
                                             #:dry-run?
                                             (assoc-ref opts 'dry-run?))
           (with-status-verbosity (assoc-ref opts 'verbosity)
-            (define manifest
+            (define manifest-from-opts
               (options/resolve-packages store opts))
+            (when (and profile
+                       (> (length (manifest-entries manifest-from-opts)) 0))
+              (leave (G_ "'--profile' cannot be used with package options~%")))
+
+            (define manifest
+              (if profile
+                (profile-manifest profile)
+                manifest-from-opts))
 
             (set-build-options-from-command-line store opts)
 
@@ -755,7 +771,9 @@ message if any test fails."
                                                                    system))
                                      (prof-drv   (manifest->derivation
                                                   manifest system bootstrap?))
-                                     (profile -> (derivation->output-path prof-drv))
+                                     (profile -> (if profile
+                                                   (readlink* profile)
+                                                   (derivation->output-path prof-drv)))
                                      (gc-root -> (assoc-ref opts 'gc-root)))
 
                   ;; First build the inputs.  This is necessary even for
diff --git a/guix/self.scm b/guix/self.scm
index 15c8ad4eb9..35fba1152d 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -793,7 +793,9 @@ itself."
     (((labels packages _ ...) ...)
      (cons package packages))))
 
-(define* (compiled-guix source #:key (version %guix-version)
+(define* (compiled-guix source #:key
+                        (version %guix-version)
+                        (channel-metadata #f)
                         (pull-version 1)
                         (name (string-append "guix-" version))
                         (guile-version (effective-version))
@@ -977,6 +979,8 @@ itself."
                                          %guix-package-name
                                          #:package-version
                                          version
+                                         #:channel-metadata
+                                         channel-metadata
                                          #:bug-report-address
                                          %guix-bug-report-address
                                          #:home-page-url
@@ -1070,6 +1074,7 @@ itself."
 (define* (make-config.scm #:key gzip xz bzip2
                           (package-name "GNU Guix")
                           (package-version "0")
+                          (channel-metadata #f)
                           (bug-report-address "bug-guix@gnu.org")
                           (home-page-url "https://guix.gnu.org"))
 
@@ -1083,6 +1088,7 @@ itself."
                                %guix-version
                                %guix-bug-report-address
                                %guix-home-page-url
+                               %channel-metadata
                                %system
                                %store-directory
                                %state-directory
@@ -1125,6 +1131,11 @@ itself."
                    (define %guix-bug-report-address #$bug-report-address)
                    (define %guix-home-page-url #$home-page-url)
 
+                   (define %channel-metadata
+                     ;; Metadata for the 'guix' channel in use.  This
+                     ;; information is used by (guix describe).
+                     '#$channel-metadata)
+
                    (define %gzip
                      #+(and gzip (file-append gzip "/bin/gzip")))
                    (define %bzip2
@@ -1249,11 +1260,14 @@ containing MODULE-FILES and possibly other files as well."
 
 (define* (guix-derivation source version
                           #:optional (guile-version (effective-version))
-                          #:key (pull-version 0))
+                          #:key (pull-version 0)
+                          channel-metadata)
   "Return, as a monadic value, the derivation to build the Guix from SOURCE
-for GUILE-VERSION.  Use VERSION as the version string.  PULL-VERSION specifies
-the version of the 'guix pull' protocol.  Return #f if this PULL-VERSION value
-is not supported."
+for GUILE-VERSION.  Use VERSION as the version string.  Use CHANNEL-METADATA
+as the channel metadata sexp to include in (guix config).
+
+PULL-VERSION specifies the version of the 'guix pull' protocol.  Return #f if
+this PULL-VERSION value is not supported."
   (define (shorten version)
     (if (and (string-every char-set:hex-digit version)
              (> (string-length version) 9))
@@ -1278,6 +1292,7 @@ is not supported."
     (set-guile-for-build guile)
     (let ((guix (compiled-guix source
                                #:version version
+                               #:channel-metadata channel-metadata
                                #:name (string-append "guix-"
                                                      (shorten version))
                                #:pull-version pull-version
diff --git a/guix/store.scm b/guix/store.scm
index e0b15abce3..81bb9eb847 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -2173,10 +2173,12 @@ valid inputs."
 (define (store-path-hash-part path)
   "Return the hash part of PATH as a base32 string, or #f if PATH is not a
 syntactically valid store path."
-  (let* ((base (store-path-base path))
-         (hash (string-take base 32)))
-    (and (string-every %nix-base32-charset hash)
-         hash)))
+  (match (store-path-base path)
+    (#f #f)
+    (base
+     (let ((hash (string-take base 32)))
+       (and (string-every %nix-base32-charset hash)
+            hash)))))
 
 (define (derivation-log-file drv)
   "Return the build log file for DRV, a derivation file name, or #f if it
diff --git a/guix/ui.scm b/guix/ui.scm
index 45ae14f83c..9cea405456 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -2123,6 +2123,14 @@ Run COMMAND with ARGS.\n"))
 (define (run-guix-command command . args)
   "Run COMMAND with the given ARGS.  Report an error when COMMAND is not
 found."
+  (define (command-hint guess commands)
+    (define command-names
+      (map (lambda (command)
+             (match (command-name command)
+               ((head tail ...) head)))
+           commands))
+    (string-closest (symbol->string guess) command-names #:threshold 3))
+
   (define module
     ;; Check if there is a matching extension.
     (match (search-path (extension-directories)
@@ -2132,9 +2140,13 @@ found."
          (lambda ()
            (resolve-interface `(guix scripts ,command)))
          (lambda _
-           (format (current-error-port)
-                   (G_ "guix: ~a: command not found~%") command)
-           (show-guix-usage))))
+           (let ((hint (command-hint command (commands))))
+             (format (current-error-port)
+                     (G_ "guix: ~a: command not found~%") command)
+             (when hint
+               (display-hint (format #f (G_ "Did you mean @code{~a}?")
+                                     hint)))
+             (show-guix-usage)))))
       (file
        (load file)
        (resolve-interface `(guix extensions ,command)))))
diff --git a/guix/utils.scm b/guix/utils.scm
index edc3503c10..96cd8c791e 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,6 +41,7 @@
                 #:select (dump-port mkdir-p delete-file-recursively
                           call-with-temporary-output-file %xz-parallel-args))
   #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
+  #:use-module ((guix combinators) #:select (fold2))
   #:use-module (guix diagnostics)           ;<location>, &error-location, etc.
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
@@ -119,7 +121,10 @@
             call-with-decompressed-port
             compressed-output-port
             call-with-compressed-output-port
-            canonical-newline-port))
+            canonical-newline-port
+
+            string-distance
+            string-closest))
 
 
 ;;;
@@ -881,6 +886,46 @@ be determined."
           ;; raising an error would upset Geiser users
           #f))))))
 
+
+;;;
+;;; String comparison.
+;;;
+
+(define (string-distance s1 s2)
+  "Compute the Levenshtein distance between two strings."
+  ;; Naive implemenation
+  (define loop
+    (mlambda (as bt)
+      (match as
+        (() (length bt))
+        ((a s ...)
+         (match bt
+           (() (length as))
+           ((b t ...)
+            (if (char=? a b)
+                (loop s t)
+                (1+ (min
+                     (loop as t)
+                     (loop s bt)
+                     (loop s t))))))))))
+
+  (let ((c1 (string->list s1))
+        (c2 (string->list s2)))
+    (loop c1 c2)))
+
+(define* (string-closest trial tests #:key (threshold 3))
+  "Return the string from TESTS that is the closest from the TRIAL,
+according to 'string-distance'.  If the TESTS are too far from TRIAL,
+according to THRESHOLD, then #f is returned."
+  (identity                              ;discard second return value
+    (fold2 (lambda (test closest minimal)
+             (let ((dist (string-distance trial test)))
+               (if (and  (< dist minimal) (< dist threshold))
+                   (values test dist)
+                   (values closest minimal))))
+           #f +inf.0
+           tests)))
+
 ;;; Local Variables:
 ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
 ;;; End: