01/01: website: packages: Anchor location url to commit id.

[Eric Bavier]

bavier pushed a commit to branch master
in repository guix-artwork.

commit fba3435fb3b07823b2c666906510442110723d56
Author: Eric Bavier <address@hidden>
Date:   Sat Feb 11 20:05:20 2017 -0600

    website: packages: Anchor location url to commit id.
    
    * website/www/packages.scm (git-description): New variable.
    (location-url): Include "?id=..." if possible.
---
 website/www/packages.scm | 22 ++++++++++++++++++++--
 1 file changed, 20 insertions(+), 2 deletions(-)

diff --git a/website/www/packages.scm b/website/www/packages.scm
index 91784ec..30153d5 100644
--- a/website/www/packages.scm
+++ b/website/www/packages.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Mathieu Lirzin <address@hidden>
 ;;; Copyright © 2013 Alex Sassmannshausen <address@hidden>
+;;; Copyright © 2017 Eric Bavier <address@hidden>
 ;;; Initially written by Luis Felipe López Acevedo <address@hidden>
 ;;; who waives all copyright interest on this file.
 ;;;
@@ -35,6 +36,7 @@
   #:use-module (guix base32)
   #:use-module ((guix download) #:select (%mirrors))
   #:use-module ((guix build download) #:select (maybe-expand-mirrors))
+  #:use-module (guix build utils)
   #:use-module (guix scripts lint)
   #:use-module (guix scripts challenge)
   #:use-module (guix scripts substitute)
@@ -47,6 +49,8 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -82,10 +86,24 @@
        (loop tail
              (cons* head item result))))))
 
+(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 git? desc))))
+
 (define (location-url loc)
   (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/";
-                 (location-file loc) "#n"
-                 (number->string (location-line loc))))
+                 (location-file loc)
+                 (or (and=> (force git-description)
+                            (cut string-append "?id=" <>))
+                     "")
+                 "#n" (number->string (location-line loc))))
 
 (define (source-url package)
   (let ((loc (package-location package)))