08/12: website: packages: Add the commit in package source URLs.

[Ludovic Courtès]

civodul pushed a commit to branch wip-website-update
in repository guix-artwork.

commit 775f03ad4917a0af9903457f07eb5f270bd96879
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jul 29 18:02:29 2017 +0200

    website: packages: Add the commit in package source URLs.
    
    This is a "port" of commit fba3435fb3b07823b2c666906510442110723d56.
    
    * website/apps/packages/utils.scm (git-description): New procedure.
    (location->ilink): Use it.  Use 'string-append' instead of
    'url-path-join'.
---
 website/apps/packages/utils.scm | 25 ++++++++++++++++++++++---
 1 file changed, 22 insertions(+), 3 deletions(-)

diff --git a/website/apps/packages/utils.scm b/website/apps/packages/utils.scm
index 1ca8069..0d4304e 100644
--- a/website/apps/packages/utils.scm
+++ b/website/apps/packages/utils.scm
@@ -1,5 +1,6 @@
 ;;; GuixSD website --- GNU's advanced distro website
 ;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2017 Eric Bavier <address@hidden>
 ;;;
 ;;; Initially written by sirgazil
 ;;; who waives all copyright interest on this file.
@@ -26,9 +27,14 @@
   #:use-module (apps packages types)
   #:use-module (guix packages)
   #:use-module (guix utils)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (texinfo)
   #:use-module (texinfo html)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 popen)
   #:export (package-description-shtml
             package-synopsis-shtml
 
@@ -67,6 +73,16 @@ vocabulary."
              (('div ('p text ...))
               text)))))
 
+(define git-description
+  (delay
+   (let* ((guix (find (lambda (p)
+                        (file-exists? (string-append p "/guix/config.scm")))
+                      %load-path))
+          (pipe (with-directory-excursion guix
+                  (open-pipe* OPEN_READ "git" "describe")))
+          (desc (read-line pipe))
+          (git? (close-pipe pipe)))
+     (and (zero? git?) desc))))
 
 (define (location->ilink loc)
   "Convert the given location LOC into an Ilink.
@@ -78,9 +94,12 @@ vocabulary."
      An Ilink object as defined in (apps packages types)."
   (ilink (basename (location-file loc))
         (guix-git-tree-url
-         (url-path-join (location-file loc)
-                        (string-append "#n"
-                                       (number->string (location-line 
loc)))))))
+         (string-append (location-file loc)
+                         (or (and=> (force git-description)
+                                    (cut string-append "?id=" <>))
+                             "")
+                         "#n"
+                         (number->string (location-line loc))))))
 
 
 ;;; TODO: Stub. Implement.