From 81b5ade74a7debbde30a98ac5dc884844f6dfeb7 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <address@hidden>
Date: Tue, 25 Apr 2017 01:46:05 +0900
Subject: [PATCH] build-system/gnu: Fix compress-documentation phase

The compress-documentation phase was breaking recursive symbolic links used
for manuals, which was made visible by the `find-files' call in the recently
added `manual-database' profile hook.

* guix/build/gnu-build-system.scm (retarget-symblink)[link]: Rename to
`symbolic-link' (`link' is a Guile function).
(points-to-symbolic-link?): Add predicate.
(maybe-compress-directory): Rename `symlinks' to `symbolic-links', use
`points-to-symbolic-link?' to filter out symbolic links which shouldn't be
retargetted and re-order the calls to `retarget-symlink' and `documentation-compressor'.
---
 guix/build/gnu-build-system.scm | 47 ++++++++++++++++++++++++++++++-----------
 1 file changed, 35 insertions(+), 12 deletions(-)

diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 1786e2e3c9..778b514375 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -511,16 +511,34 @@ and 'man/'.  This phase moves directories to the right place if needed."
   "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files
 found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with
 DOCUMENTATION-COMPRESSOR-FLAGS."
-  (define (retarget-symlink link)
-    (let ((target (readlink link)))
-      (delete-file link)
-      (symlink (string-append target compressed-documentation-extension)
-               link)))
+  (define (retarget-symlink symbolic-link)
+    (let ((target (readlink symbolic-link)))
+      (delete-file symbolic-link)
+      (symlink (string-append target
+                              compressed-documentation-extension)
+               symbolic-link)))
 
   (define (has-links? file)
     ;; Return #t if FILE has hard links.
     (> (stat:nlink (lstat file)) 1))
 
+  (define (points-to-symbolic-link? symbolic-link)
+    ;; Return #t if SYMBOLIC-LINK points to another symbolic link.
+    (let* ((target (readlink symbolic-link))
+           (target-absolute (if (string-prefix? "/" target)
+                                (target)
+                                (string-join `(,(dirname symbolic-link) ,target)
+                                             "/"))))
+      (catch 'system-error
+        (lambda ()
+          (symbolic-link? target-absolute))
+        (lambda args
+          (if (= ENOENT (system-error-errno args))
+              (format (current-error-port) "The symbolic link '~a' target is
+missing: '~a'\n" symbolic-link target-absolute)
+              (apply throw args))
+          #f))))
+
   (define (maybe-compress-directory directory regexp)
     (or (not (directory-exists? directory))
         (match (find-files directory regexp)
@@ -534,16 +552,21 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
            (call-with-values
                (lambda ()
                  (partition symbolic-link? files))
-             (lambda (symlinks regular-files)
+             (lambda (symbolic-links regular-files)
                ;; Compress the non-symlink files, and adjust symlinks to refer
                ;; to the compressed files.  Leave files that have hard links
                ;; unchanged ('gzip' would refuse to compress them anyway.)
-               (and (zero? (apply system* documentation-compressor
-                                  (append documentation-compressor-flags
-                                          (remove has-links? regular-files))))
-                    (every retarget-symlink
-                           (filter (cut string-match regexp <>)
-                                   symlinks)))))))))
+               ;; Also, do not retarget symbolic links pointing to other
+               ;; symbolic links, since these are not compressed.
+               (and (every retarget-symlink
+                           (filter (lambda (s)
+                                     (and (not (points-to-symbolic-link? s))
+                                          (string-match regexp s)))
+                                   symbolic-links))
+                    (zero?
+                     (apply system* documentation-compressor
+                            (append documentation-compressor-flags
+                                    (remove has-links? regular-files)))))))))))
 
   (define (maybe-compress output)
     (and (maybe-compress-directory (string-append output "/share/man")
-- 
2.12.2