[bug#35263] build: go-build-system: Ensure uniform unpacking directory.

Message ID 87tvf1nshy.fsf@gmail.com
State Accepted
Headers show
Series [bug#35263] build: go-build-system: Ensure uniform unpacking directory. | expand

Checks

Context Check Description
cbaines/applying patch fail Apply failed

Commit Message

Maxim Cournoyer April 14, 2019, 4:03 a.m. UTC
This fixes a problem in the go-build-system's unpack phase.

Comments

Maxim Cournoyer May 6, 2019, 12:10 a.m. UTC | #1
Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

> This fixes a problem in the go-build-system's unpack phase.

I went ahead and pushed this with commit
f42e4ebb56fe4f16991ca6c6e060c8f3535865cb.

Maxim

Patch

From 1f7535fbe28f7ac96e824b792e9f1a140b8c54cd Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 00:00:08 -0400
Subject: [PATCH 3/3] build: go-build-system: Ensure uniform unpacking
 directory.

Depending on whether the source is a directory or an archive, we strip the
source directory or preserve it, respectively.  This change makes it so that
whether the type of the source, it is unpacked at the expected location given
by the IMPORT-PATH of the Go build system.

* guix/build/go-build-system.scm: Add the (ice-9 ftw) module.
(unpack): Add inner procedure to maybe strip the top level directory of an
archive, document it and use it.
---
 guix/build/go-build-system.scm | 35 +++++++++++++++++++++++++---------
 1 file changed, 26 insertions(+), 9 deletions(-)

diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index e59aa59092..c1a0d6441c 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -22,6 +22,7 @@ 
   #:use-module (guix build union)
   #:use-module (guix build utils)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
   #:use-module (srfi srfi-1)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
@@ -151,13 +152,31 @@  dependencies, so it should be self-contained."
   #t)
 
 (define* (unpack #:key source import-path unpack-path #:allow-other-keys)
-  "Relative to $GOPATH, unpack SOURCE in the UNPACK-PATH, or the IMPORT-PATH is
-the UNPACK-PATH is unset.  When SOURCE is a directory, copy it instead of
+  "Relative to $GOPATH, unpack SOURCE in UNPACK-PATH, or IMPORT-PATH when
+UNPACK-PATH is unset.  If the SOURCE archive has a single top level directory,
+it is stripped so that the sources appear directly under UNPACK-PATH.  When
+SOURCE is a directory, copy its content into UNPACK-PATH instead of
 unpacking."
-  (if (string-null? import-path)
-      ((display "WARNING: The Go import path is unset.\n")))
-  (if (string-null? unpack-path)
-      (set! unpack-path import-path))
+  (define (unpack-maybe-strip source dest)
+    (let* ((scratch-dir (string-append (or (getenv "TMPDIR") "/tmp")
+                                       "/scratch-dir"))
+           (out (mkdir-p scratch-dir)))
+      (with-directory-excursion scratch-dir
+        (if (string-suffix? ".zip" source)
+            (invoke "unzip" source)
+            (invoke "tar" "-xvf" source))
+        (let ((top-level-files (remove (lambda (x)
+                                         (member x '("." "..")))
+                                       (scandir "."))))
+          (match top-level-files
+            ((top-level-file)
+             (when (file-is-directory? top-level-file)
+               (copy-recursively top-level-file dest #:keep-mtime? #t)))
+            (_
+             (copy-recursively "." dest #:keep-mtime? #t)))
+          #t))
+      (delete-file-recursively scratch-dir)))
+
   (when (string-null? import-path)
     ((display "WARNING: The Go import path is unset.\n")))
   (when (string-null? unpack-path)
@@ -168,9 +187,7 @@  unpacking."
         (begin
           (copy-recursively source dest #:keep-mtime? #t)
           #t)
-        (if (string-suffix? ".zip" source)
-            (invoke "unzip" "-d" dest source)
-            (invoke "tar" "-C" dest "-xvf" source)))))
+        (unpack-maybe-strip source dest))))
 
 (define (go-package? name)
   (string-prefix? "go-" name))
-- 
2.20.1