Merge remote-tracking branch 'origin/master' into staging

3 files changed, 139 insertions, 34 deletions

diff --git a/guix/build/android-repo.scm b/guix/build/android-repo.scm
new file mode 100644
index 0000000000..db8c4d127b
--- /dev/null
+++ b/guix/build/android-repo.scm
@@ -0,0 +1,75 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build android-repo)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (ice-9 format)
+  #:export (android-repo-fetch))
+
+;;; Commentary:
+;;;
+;;; This is the build-side support code of (guix android-repo-download).
+;;; It allows a multirepository managed by the git-repo tool to be cloned and
+;;; checked out at a specific revision.
+;;;
+;;; Code:
+
+(define* (android-repo-fetch manifest-url manifest-revision directory
+                             #:key (git-repo-command "git-repo"))
+  "Fetch packages according to the manifest at MANIFEST-URL with
+MANIFEST-REVISION.  MANIFEST-REVISION must be either a revision
+or a branch.  Return #t on success, #f otherwise."
+
+  ;; Disable TLS certificate verification.  The hash of the checkout is known
+  ;; in advance anyway.
+  (setenv "GIT_SSL_NO_VERIFY" "true")
+
+  (mkdir-p directory)
+
+  (guard (c ((invoke-error? c)
+             (format (current-error-port)
+                     "android-repo-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
+                     (invoke-error-program c)
+                     (invoke-error-arguments c)
+                     (or (invoke-error-exit-status c) ;XXX: not quite accurate
+                         (invoke-error-stop-signal c)
+                         (invoke-error-term-signal c)))
+             (delete-file-recursively directory)
+             #f))
+    (with-directory-excursion directory
+      (invoke git-repo-command "init" "-u" manifest-url "-b" manifest-revision
+              "--depth=1")
+      (invoke git-repo-command "sync" "-c" "--fail-fast" "-v" "-j"
+              (number->string (parallel-job-count)))
+
+      ;; Delete vendor/**/.git, system/**/.git, toolchain/**/.git,
+      ;; .repo/**/.git etc since they contain timestamps.
+      (for-each delete-file-recursively
+       (find-files "." "^\\.git$" #:directories? #t))
+
+      ;; Delete git state directories since they contain timestamps.
+      (for-each delete-file-recursively
+       (find-files ".repo" "^.*\\.git$" #:directories? #t))
+
+      ;; This file contains timestamps.
+      (delete-file ".repo/.repo_fetchtimes.json")
+      #t)))
+
+;;; android-repo.scm ends here
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
index 377e428341..867f3c10bb 100644
--- a/guix/build/download-nar.scm
+++ b/guix/build/download-nar.scm
@@ -20,7 +20,7 @@
   #:use-module (guix build download)
   #:use-module (guix build utils)
   #:use-module ((guix serialization) #:hide (dump-port*))
-  #:use-module (guix zlib)
+  #:autoload   (zlib) (call-with-gzip-input-port)
   #:use-module (guix progress)
   #:use-module (web uri)
   #:use-module (srfi srfi-11)
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 91f62138d0..28253ce2f0 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
-;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -73,37 +73,35 @@ and parameters ~s~%"
         (error "no Setup.hs nor Setup.lhs found"))))
 
 (define* (configure #:key outputs inputs tests? (configure-flags '())
-                    #:allow-other-keys)
+                    (extra-directories '()) #:allow-other-keys)
   "Configure a given Haskell package."
   (let* ((out (assoc-ref outputs "out"))
          (doc (assoc-ref outputs "doc"))
          (lib (assoc-ref outputs "lib"))
-         (bin (assoc-ref outputs "bin"))
          (name-version (strip-store-file-name out))
-         (input-dirs (match inputs
-                       (((_ . dir) ...)
-                        dir)
-                       (_ '())))
+         (extra-dirs (filter-map (cut assoc-ref inputs <>) extra-directories))
          (ghc-path (getenv "GHC_PACKAGE_PATH"))
-         (params (append `(,(string-append "--prefix=" out))
-                         `(,(string-append "--libdir=" (or lib out) "/lib"))
-                         `(,(string-append "--bindir=" (or bin out) "/bin"))
-                         `(,(string-append
-                             "--docdir=" (or doc out)
-                             "/share/doc/" name-version))
-                         '("--libsubdir=$compiler/$pkg-$version")
-                         `(,(string-append "--package-db=" %tmp-db-dir))
-                         '("--global")
-                         `(,@(map
-                              (cut string-append "--extra-include-dirs=" <>)
-                              (search-path-as-list '("include") input-dirs)))
-                         `(,@(map
-                              (cut string-append "--extra-lib-dirs=" <>)
-                              (search-path-as-list '("lib") input-dirs)))
-                         (if tests?
-                             '("--enable-tests")
-                             '())
-                         configure-flags)))
+         (params `(,(string-append "--prefix=" out)
+                   ,(string-append "--libdir=" (or lib out) "/lib")
+                   ,(string-append "--docdir=" (or doc out)
+                                   "/share/doc/" name-version)
+                   "--libsubdir=$compiler/$pkg-$version"
+                   ,(string-append "--package-db=" %tmp-db-dir)
+                   "--global"
+                   ,@(map (cut string-append "--extra-include-dirs=" <>)
+                          (search-path-as-list '("include") extra-dirs))
+                   ,@(map (cut string-append "--extra-lib-dirs=" <>)
+                          (search-path-as-list '("lib") extra-dirs))
+                   ,@(if tests?
+                         '("--enable-tests")
+                         '())
+                   ;; Build and link with shared libraries
+                   "--enable-shared"
+                   "--enable-executable-dynamic"
+                   "--ghc-option=-fPIC"
+                   ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out)
+                                   "/lib/$compiler/$pkg-$version")
+                   ,@configure-flags)))
     ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset
     ;; and restore it.
     (unsetenv "GHC_PACKAGE_PATH")
@@ -121,13 +119,27 @@ and parameters ~s~%"
     (setenv "GHC_PACKAGE_PATH" ghc-path)
     #t))
 
-(define* (build #:rest empty)
+(define* (build #:key parallel-build? #:allow-other-keys)
   "Build a given Haskell package."
-  (run-setuphs "build" '()))
+  (run-setuphs "build"
+               (if parallel-build?
+                   `(,(string-append "--ghc-option=-j" (number->string (parallel-job-count))))
+                   '())))
 
-(define* (install #:rest empty)
+(define* (install #:key outputs #:allow-other-keys)
   "Install a given Haskell package."
-  (run-setuphs "copy" '()))
+  (run-setuphs "copy" '())
+  (when (assoc-ref outputs "static")
+    (let ((static (assoc-ref outputs "static"))
+          (lib (or (assoc-ref outputs "lib")
+                   (assoc-ref outputs "out"))))
+      (for-each (lambda (static-lib)
+                  (let* ((subdir (string-drop static-lib (string-length lib)))
+                         (new    (string-append static subdir)))
+                    (mkdir-p (dirname new))
+                    (rename-file static-lib new)))
+                (find-files lib "\\.a$"))))
+  #t)
 
 (define (grep rx port)
   "Given a regular-expression RX including a group, read from PORT until the
@@ -227,9 +239,10 @@ given Haskell package."
              (loop seen tail))))))
 
   (let* ((out (assoc-ref outputs "out"))
+         (doc (assoc-ref outputs "doc"))
          (haskell  (assoc-ref inputs "haskell"))
          (name-verion (strip-store-file-name haskell))
-         (lib (string-append out "/lib"))
+         (lib (string-append (or (assoc-ref outputs "lib") out) "/lib"))
          (config-dir (string-append lib
                                     "/" name-verion
                                     "/" name ".conf.d"))
@@ -241,8 +254,25 @@ given Haskell package."
     ;; The conf file is created only when there is a library to register.
     (when (file-exists? config-file)
       (mkdir-p config-dir)
-      (let* ((config-file-name+id
-              (call-with-ascii-input-file config-file (cut grep id-rx <>))))
+      (let ((config-file-name+id
+             (call-with-ascii-input-file config-file (cut grep id-rx <>))))
+
+        ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the
+        ;; "haddock-interfaces" field and removing the optional "haddock-html"
+        ;; field in the generated .conf file.
+        (when doc
+          (substitute* config-file
+            (("^haddock-html: .*") "\n")
+            (((format #f "^haddock-interfaces: ~a" doc))
+             (string-append "haddock-interfaces: " lib)))
+          ;; Move the referenced file to the "lib" (or "out") output.
+          (match (find-files doc "\\.haddock$")
+            ((haddock-file . rest)
+             (let* ((subdir (string-drop haddock-file (string-length doc)))
+                    (new    (string-append lib subdir)))
+               (mkdir-p (dirname new))
+               (rename-file haddock-file new)))
+            (_ #f)))
         (install-transitive-deps config-file %tmp-db-dir config-dir)
         (rename-file config-file
                      (string-append config-dir "/"