Figure out channel name a bit better

guix/extensions/channel.scm

@@ -11,8 +11,14 @@
   #:use-module ((guix diagnostics)
                 #:select (location-file
                            location-line))
+  #:use-module ((guix inferior)
+                #:select (cached-channel-instance))
+  #:use-module ((guix store)
+                #:select (with-store
+                           with-build-handler))
   #:use-module ((guix git)
-                #:select (repository-info))
+                #:select (repository-info
+                           with-git-error-handling))
 
   #:use-module ((srfi srfi-1)
                 #:select (break))
@@ -177,20 +183,35 @@ CHAN. Append the defautl guix channel if not present."
                      directory
                      file-name-separator-string
                      ".guix-introduction")))
-             (if (file-exists? file) file #f))))
-    (channel
-      (name
-        (string->symbol
-          (string-replace-substring
-            (basename channel-directory)
-            file-name-separator-string
-            "")))
-      (url directory)
-      (commit commit)
-      (introduction 
-        (and introduction-file
-             (sexp->channel-introduction
-               (read (open-file introduction-file OPEN_READ))))))))
+             (if (file-exists? file) file #f)))
+         (chan
+           (channel
+             (name
+               (string->symbol
+                 (basename
+                   (canonicalize-path
+                     channel-directory))))
+             (url directory)
+             (commit commit)
+             (introduction
+               (and introduction-file
+                    (sexp->channel-introduction
+                      (read (open-file introduction-file OPEN_READ)))))))
+         (metadata-file
+           (channel-metadata-file chan))
+         (metadata
+           (and metadata-file
+                (read (open-file
+                        metadata-file
+                        OPEN_READ))))
+         (name (assq-ref
+                 metadata
+                 'name)))
+    (if name
+      (channel
+        (inherit chan)
+        (name (car name)))
+      chan)))
 
 (define-command (guix-channel . args)
                 (category extension)
@@ -216,54 +237,55 @@ CHAN. Append the defautl guix channel if not present."
               (acons 'exec command opts)))))))
 
   (with-error-handling
-    (let* ((commands (parse-arguments))
-           (args (reverse (filter string? commands))))
-      (and (null? commands)
-           (warning (G_ "nothing to do~%")))
-      (let* ((channel-directory
-               (if (not (null? args))
-                 (car args)
-                 "/etc/guix-channel/")))
-        (if (not (and (file-exists? channel-directory)))
-          (error (G_ "invalid channel or channel not found~%"))
-          (let* ((chan (directory->channel channel-directory))
-                 (channel-file
-                   (channel-metadata-file chan)))
-            (and (assq-ref commands 'lock)
-                 (let ((new
-                         (update-channels
-                           channel-file
-                           (lock-channel-commits
-                             (assoc-ref commands 'lock)))))
-                   (and new
-                        (pretty-print
-                          new
-                          (open-file channel-file OPEN_WRITE)))))
+    (with-git-error-handling
+      (let* ((commands (parse-arguments))
+             (args (reverse (filter string? commands))))
+        (and (null? commands)
+             (warning (G_ "nothing to do~%")))
+        (let* ((channel-directory
+                 (if (not (null? args))
+                   (car args)
+                   "/etc/guix-channel/")))
+          (if (not (and (file-exists? channel-directory)))
+            (error (G_ "invalid channel or channel not found~%"))
+            (let* ((chan (directory->channel channel-directory))
+                   (channel-file
+                     (channel-metadata-file chan)))
+              (and (assq-ref commands 'lock)
+                   (let ((new
+                           (update-channels
+                             channel-file
+                             (lock-channel-commits
+                               (assoc-ref commands 'lock)))))
+                     (and new
+                          (pretty-print
+                            new
+                            (open-file channel-file OPEN_WRITE)))))
 
-            (and (assq-ref commands 'update)
-                 (let ((new
-                         (update-channels
-                           channel-file
-                           (update-channel-commits
-                             (assoc-ref commands 'update)))))
-                   (and new
-                        (pretty-print
-                          new
-                          (open-file channel-file OPEN_WRITE)))))
+              (and (assq-ref commands 'update)
+                   (let ((new
+                           (update-channels
+                             channel-file
+                             (update-channel-commits
+                               (assoc-ref commands 'update)))))
+                     (and new
+                          (pretty-print
+                            new
+                            (open-file channel-file OPEN_WRITE)))))
 
-            (and (assq-ref commands 'to-channels)
-                 (let ((channel-code
-                         `(list ,@(map channel->code (channel->channels chan)))))
-                   (and channel-code
-                        (pretty-print channel-code))))
+              (and (assq-ref commands 'to-channels)
+                   (let ((channel-code
+                           `(list ,@(map channel->code (channel->channels chan)))))
+                     (and channel-code
+                          (pretty-print channel-code))))
 
-            (and (assq-ref commands 'exec)
-                 (let* ((temp-channels (mkstemp "/tmp/channels-XXXXXX"))
-                        (temp-channels-file (port-filename temp-channels))
-                        (channel-code
-                          `(list ,@(map channel->code (channel->channels chan)))))
-                   (and channel-code
-                        (write channel-code temp-channels)
-                        (close-port temp-channels)
-                        (apply guix-time-machine "-qC" temp-channels-file (assq-ref commands 'exec)))
-                   (delete-file temp-channels-file)))))))))
+              (and (assq-ref commands 'exec)
+                   (let* ((temp-channels (mkstemp "/tmp/channels-XXXXXX"))
+                          (temp-channels-file (port-filename temp-channels))
+                          (channel-code
+                            `(list ,@(map channel->code (channel->channels chan)))))
+                     (and channel-code
+                          (write channel-code temp-channels)
+                          (close-port temp-channels)
+                          (apply guix-time-machine "-qC" temp-channels-file (assq-ref commands 'exec)))
+                     (delete-file temp-channels-file))))))))))