code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.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 gremlin)
  #:use-module (guix elf)
  #:use-module ((guix build utils) #:select (store-file-name?))
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:export (elf-error?
            elf-error-elf
            invalid-segment-size?
            invalid-segment-size-segment

            elf-dynamic-info
            elf-dynamic-info?
            elf-dynamic-info-soname
            elf-dynamic-info-needed
            elf-dynamic-info-rpath
            elf-dynamic-info-runpath
            expand-origin

            validate-needed-in-runpath))

;;; Commentary:
;;;
;;; A gremlin is sort-of like an elf, you know, and this module provides tools
;;; to deal with dynamic-link information from ELF files.
;;;
;;; Code:

(define-condition-type &elf-error &error
  elf-error?
  (elf elf-error-elf))

(define-condition-type &invalid-segment-size &elf-error
  invalid-segment-size?
  (segment invalid-segment-size-segment))

(define (dynamic-link-segment elf)
  "Return the 'PT_DYNAMIC' segment of ELF--i.e., the segment that contains
dynamic linking information."
  (let ((size (bytevector-length (elf-bytes elf))))
    (find (lambda (segment)
            (unless (<= (+ (elf-segment-offset segment)
                           (elf-segment-filesz segment))
                        size)
              ;; This happens on separate debug output files created by
              ;; 'strip --only-keep-debug' (Binutils 2.25.)
              (raise (condition (&invalid-segment-size
                                 (elf elf)
                                 (segment segment)))))

            (= (elf-segment-type segment) PT_DYNAMIC))
          (elf-segments elf))))

(define (word-reader size byte-order)
  "Return a procedure to read a word of SIZE bytes according to BYTE-ORDER."
  (case size
    ((8)
     (lambda (bv index)
       (bytevector-u64-ref bv index byte-order)))
    ((4)
     (lambda (bv index)
       (bytevector-u32-ref bv index byte-order)))))

;; Dynamic entry:
;;
;; typedef struct
;; {
;;   Elf64_Sxword       d_tag;   /* Dynamic entry type */
;;   union
;;     {
;;       Elf64_Xword d_val;      /* Integer value */
;;       Elf64_Addr d_ptr;       /* Address value */
;;     } d_un;
;; } Elf64_Dyn;

(define (raw-dynamic-entries elf segment)
  "Return as a list of type/value pairs all the dynamic entries found in
SEGMENT, the 'PT_DYNAMIC' segment of ELF.  In the result, each car is a DT_
value, and the interpretation of the cdr depends on the type."
  (define start
    (elf-segment-offset segment))
  (define bytes
    (elf-bytes elf))
  (define word-size
    (elf-word-size elf))
  (define byte-order
    (elf-byte-order elf))
  (define read-word
    (word-reader word-size byte-order))

  (let loop ((offset 0)
             (result '()))
    (if (>= offset (elf-segment-memsz segment))
        (reverse result)
        (let ((type  (read-word bytes (+ start offset)))
              (value (read-word bytes (+ start offset word-size))))
          (if (= type DT_NULL)                    ;finished?
              (reverse result)
              (loop (+ offset (* 2 word-size))
                    (alist-cons type value result)))))))

(define (vma->offset elf vma)
  "Convert VMA, a virtual memory address, to an offset within ELF.

Do that by looking at the loadable program segment (PT_LOAD) of ELF that
contains VMA and by taking into account that segment's virtual address and
offset."
  ;; See 'offset_from_vma' in Binutils.
  (define loads
    (filter (lambda (segment)
              (= (elf-segment-type segment) PT_LOAD))
            (elf-segments elf)))

  (let ((load (find (lambda (segment)
                      (let ((vaddr (elf-segment-vaddr segment)))
                        (and (>= vma vaddr)
                             (< vma (+ (elf-segment-memsz segment)
                                       vaddr)))))
                    loads)))
    (+ (- vma (elf-segment-vaddr load))
       (elf-segment-offset load))))

(define (dynamic-entries elf segment)
  "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
of ELF, as a list of type/value pairs.  The type is a DT_ value, and the value
may be a string or an integer depending on the entry type (for instance, the
value of DT_NEEDED entries is a string.)"
  (define entries
    (raw-dynamic-entries elf segment))

  (define string-table-offset
    (any (match-lambda
            ((type . value)
             (and (= type DT_STRTAB) value))
            (_ #f))
         entries))

  (define (interpret-dynamic-entry type value)
    (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
           (if string-table-offset
               (pointer->string
                (bytevector->pointer (elf-bytes elf)
                                     (vma->offset
                                      elf
                                      (+ string-table-offset value))))
               value))
          (else
           value)))

  (map (match-lambda
         ((type . value)
          (cons type (interpret-dynamic-entry type value))))
       entries))

;;;
;;; High-level interface.
;;;

(define-record-type <elf-dynamic-info>
  (%elf-dynamic-info soname needed rpath runpath)
  elf-dynamic-info?
  (soname    elf-dynamic-info-soname)
  (needed    elf-dynamic-info-needed)
  (rpath     elf-dynamic-info-rpath)
  (runpath   elf-dynamic-info-runpath))

(define search-path->list
  (let ((not-colon (char-set-complement (char-set #\:))))
    (lambda (str)
      "Split STR on ':' characters."
      (string-tokenize str not-colon))))

(define (elf-dynamic-info elf)
  "Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
#f if ELF lacks dynamic-link information."
  (match (dynamic-link-segment elf)
    (#f #f)
    ((? elf-segment? dynamic)
     (let ((entries (dynamic-entries elf dynamic)))
       (%elf-dynamic-info (assv-ref entries DT_SONAME)
                          (filter-map (match-lambda
                                        ((type . value)
                                         (and (= type DT_NEEDED) value))
                                        (_ #f))
                                      entries)
                          (or (and=> (assv-ref entries DT_RPATH)
                                     search-path->list)
                              '())
                          (or (and=> (assv-ref entries DT_RUNPATH)
                                     search-path->list)
                              '()))))))

(define %libc-libraries
  ;; List of libraries as of glibc 2.21 (there are more but those are
  ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.)
  '("libanl.so"
    "libcrypt.so"
    "libc.so"
    "libdl.so"
    "libm.so"
    "libnsl.so"                                   ;NEEDED by nscd
    "libpthread.so"
    "libresolv.so"
    "librt.so"
    "libutil.so"))

(define (libc-library? lib)
  "Return #t if LIB is one of the libraries shipped with the GNU C Library."
  (find (lambda (libc-lib)
          (string-prefix? libc-lib lib))
        %libc-libraries))

(define (expand-variable str variable value)
  "Replace occurrences of '$VARIABLE' or '${VARIABLE}' in STR with VALUE."
  (define variables
    (list (string-append "$" variable)
          (string-append "${" variable "}")))

  (let loop ((thing variables)
             (str   str))
    (match thing
      (()
       str)
      ((head tail ...)
       (let ((index (string-contains str head))
             (len   (string-length head)))
         (loop (if index variables tail)
               (if index
                   (string-replace str value
                                   index (+ index len))
                   str)))))))

(define (expand-origin str directory)
  "Replace occurrences of '$ORIGIN' in STR with DIRECTORY."
  (expand-variable str "ORIGIN" directory))

(define* (validate-needed-in-runpath file
                                     #:key (always-found? libc-library?))
  "Return #t if all the libraries listed as FILE's 'DT_NEEDED' entries are
present in its RUNPATH, or if FILE lacks dynamic-link information.  Return #f
otherwise.  Libraries whose name matches ALWAYS-FOUND? are considered to be
always available."
  (guard (c ((invalid-segment-size? c)
             (let ((segment (invalid-segment-size-segment c)))
               (format (current-error-port)
                       "~a: error: offset + size of segment ~a (type ~a) \
exceeds total size~%"
                       file
                       (elf-segment-index segment)
                       (elf-segment-type segment))
               #f)))

    (let* ((elf     (call-with-input-file file
                      (compose parse-elf get-bytevector-all)))
           (expand  (cute expand-origin <> (dirname file)))
           (dyninfo (elf-dynamic-info elf)))
      (when dyninfo
        ;; XXX: In theory we should also expand $PLATFORM and $LIB, but these
        ;; appear to be really unused.
        (let* ((expanded  (map expand (elf-dynamic-info-runpath dyninfo)))
               (runpath   (filter store-file-name? expanded))
               (bogus     (remove store-file-name? expanded))
               (needed    (remove always-found?
                                  (elf-dynamic-info-needed dyninfo)))
               (not-found (remove (cut search-path runpath <>)
                                  needed)))
          (unless (null? bogus)
            (format (current-error-port)
                    "~a: warning: RUNPATH contains bogus entries: ~s~%"
                    file bogus))

          (for-each (lambda (lib)
                      (format (current-error-port)
                              "~a: error: depends on '~a', which cannot \
be found in RUNPATH ~s~%"
                              file lib runpath))
                    not-found)
          ;; (when (null? not-found)
          ;;   (format (current-error-port) "~a is OK~%" file))
          (null? not-found))))))

;;; gremlin.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.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 guile-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (guix build utils)
  #:export (target-guile-effective-version
            %standard-phases
            guile-build))

(define* (target-guile-effective-version #:optional guile)
  "Return the effective version of GUILE or whichever 'guile' is in $PATH.
Return #false if it cannot be determined."
  (let* ((pipe (open-pipe* OPEN_READ
                           (if guile
                               (string-append guile "/bin/guile")
                               "guile")
                           "-c" "(display (effective-version))"))
         (line (read-line pipe)))
    (and (zero? (close-pipe pipe))
         (string? line)
         line)))

(define (file-sans-extension file)                ;TODO: factorize
  "Return the substring of FILE without its extension, if any."
  (let ((dot (string-rindex file #\.)))
    (if dot
        (substring file 0 dot)
        file)))

(define %scheme-file-regexp
  ;; Regexp to match Scheme files.
  "\\.(scm|sls)$")

(define %documentation-file-regexp
  ;; Regexp to match README files and the likes.
  "^(README.*|.*\\.html|.*\\.org|.*\\.md)$")

(define* (set-locale-path #:key inputs native-inputs
                          #:allow-other-keys)
  "Set 'GUIX_LOCPATH'."
  (match (assoc-ref (or native-inputs inputs) "locales")
    (#f #t)
    (locales
     (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
     #t)))

(define* (build #:key outputs inputs native-inputs
                (source-directory ".")
                (compile-flags '())
                (scheme-file-regexp %scheme-file-regexp)
                target
                #:allow-other-keys)
  "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP."
  (let* ((out        (assoc-ref outputs "out"))
         (guile      (assoc-ref (or native-inputs inputs) "guile"))
         (effective  (target-guile-effective-version guile))
         (module-dir (string-append out "/share/guile/site/"
                                    effective))
         (go-dir     (string-append out "/lib/guile/"
                                    effective "/site-ccache/"))
         (guild      (string-append guile "/bin/guild"))
         (flags      (if target
                         (cons (string-append "--target=" target)
                               compile-flags)
                         compile-flags)))
    (if target
        (format #t "Cross-compiling for '~a' with Guile ~a...~%"
                target effective)
        (format #t "Compiling with Guile ~a...~%" effective))
    (format #t "compile flags: ~s~%" flags)

    ;; Make installation directories.
    (mkdir-p module-dir)
    (mkdir-p go-dir)

    ;; Compile .scm files and install.
    (setenv "GUILE_AUTO_COMPILE" "0")
    (setenv "GUILE_LOAD_COMPILED_PATH"
            (string-append go-dir
                           (match (getenv "GUILE_LOAD_COMPILED_PATH")
                             (#f "")
                             (path (string-append ":" path)))))
    (for-each (lambda (file)
                (let* ((go (string-append go-dir
                                          (file-sans-extension file)
                                          ".go")))
                  ;; Install source module.
                  (install-file (string-append source-directory "/" file)
                                (string-append module-dir
                                               "/" (dirname file)))

                  ;; Install and compile module.
                  (apply invoke guild "compile" "-L" source-directory
                         "-o" go
                         (string-append source-directory "/" file)
                         flags)))

              ;; Arrange to strip SOURCE-DIRECTORY from file names.
              (with-directory-excursion source-directory
                (find-files "." scheme-file-regexp)))
    #t))

(define* (install-documentation #:key outputs
                                (documentation-file-regexp
                                 %documentation-file-regexp)
                                #:allow-other-keys)
  "Install files that mactch DOCUMENTATION-FILE-REGEXP."
  (let* ((out (assoc-ref outputs "out"))
         (doc (string-append out "/share/doc/"
                             (strip-store-file-name out))))
    (for-each (cut install-file <> doc)
              (find-files "." documentation-file-regexp))
    #t))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (add-before 'install-locale 'set-locale-path
      set-locale-path)
    (replace 'build build)
    (add-after 'build 'install-documentation
      install-documentation)
    (delete 'check)
    (delete 'strip)
    (delete 'validate-runpath)
    (delete 'install)))

(define* (guile-build #:key (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given Guile package, applying all of PHASES in order."
  (apply gnu:gnu-build #:phases phases args))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Pierre Neidhardt <mail@ambrevar.xyz>
;;;
;;; 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 gx)
  #:use-module (guix build utils)
  #:use-module (ice-9 popen)
  #:export (gx-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix gx-download).  It allows a
;;; gx hash to be fetched.
;;;
;;; Code:

(define* (gx-fetch hash directory
                   #:key (gx-command "gx"))
  "Fetch IPFS HASH into DIRECTORY.  HASH must be a valid IPFS hash.
Return #t on success, #f otherwise."

  (mkdir-p directory)

  (with-directory-excursion directory
    ;; TODO: Silence verbose output.

    ;; Initialization is interactive, but we can shut it up by piping it to
    ;; nothing.
    (let ((port (open-pipe* OPEN_WRITE gx-command "init")))
      (display "\n" port)
      (if (not (eqv? 0 (status:exit-val (close-pipe port))))
          (error "Cannot initialize gx package")))

    ;; Fetch to the "vendor" directory.
    (let ((port (open-pipe* OPEN_WRITE gx-command "import" "--local" hash)))
      (display "N\n" port)
      (if (not (eqv? 0 (status:exit-val (close-pipe port))))
          (error "Cannot import gx package")))

    (delete-file "package.json")
    (mkdir-p   "gx/ipfs")
    (rename-file (string-append  "vendor/gx/ipfs/" hash) (string-append "gx/ipfs/" hash))
    (delete-file-recursively "vendor")
    #t))

;;; gx.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Paul van der Walt <paul@denknerd.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 haskell-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 ftw)
  #:export (%standard-phases
            haskell-build))

;; Commentary:
;;
;; Builder-side code of the standard Haskell package build procedure.
;;
;; The Haskell compiler, to find libraries, relies on a library database with
;; a binary cache. For GHC the cache has to be named 'package.cache'. If every
;; library would generate the cache at build time, then they would clash in
;; profiles. For this reason we do not generate the cache when we generate
;; libraries substitutes. Instead:
;;
;; - At build time we use the 'setup-compiler' phase to generate a temporary
;;   library database and its cache.
;;
;; - We generate the cache when a profile is created.
;;
;; Code:

;; Directory where we create the temporary libraries database with its cache
;; as required by the compiler.
(define %tmp-db-dir
  (string-append (or (getenv "TMP") "/tmp")
                 "/package.conf.d"))

(define (run-setuphs command params)
  (let ((setup-file (cond
                     ((file-exists? "Setup.hs")
                      "Setup.hs")
                     ((file-exists? "Setup.lhs")
                      "Setup.lhs")
                     (else
                      #f))))
    (if setup-file
        (begin
          (format #t "running \"runhaskell Setup.hs\" with command ~s \
and parameters ~s~%"
                  command params)
          (apply invoke "runhaskell" setup-file command params))
        (error "no Setup.hs nor Setup.lhs found"))))

(define* (configure #:key outputs inputs tests? (configure-flags '())
                    #: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"))
         (input-dirs (match inputs
                       (((_ . dir) ...)
                        dir)
                       (_ '())))
         (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/" (package-name-version out)))
                         '("--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)))
    ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset
    ;; and restore it.
    (unsetenv "GHC_PACKAGE_PATH")

    ;; For packages where the Cabal build-type is set to "Configure",
    ;; ./configure will be executed.  In these cases, the following
    ;; environment variable is needed to be able to find the shell executable.
    ;; For other package types, the configure script isn't present.  For more
    ;; information, see the Build Information section of
    ;; <https://www.haskell.org/cabal/users-guide/developing-packages.html>.
    (when (file-exists? "configure")
      (setenv "CONFIG_SHELL" "sh"))
    (run-setuphs "configure" params)

    (setenv "GHC_PACKAGE_PATH" ghc-path)
    #t))

(define* (build #:rest empty)
  "Build a given Haskell package."
  (run-setuphs "build" '()))

(define* (install #:rest empty)
  "Install a given Haskell package."
  (run-setuphs "copy" '()))

(define (package-name-version store-dir)
  "Given a store directory STORE-DIR return 'name-version' of the package."
  (let* ((base (basename store-dir)))
    (string-drop base
                 (+ 1 (string-index base #\-)))))

(define (grep rx port)
  "Given a regular-expression RX including a group, read from PORT until the
first match and return the content of the group."
  (let ((line (read-line port)))
    (if (eof-object? line)
        #f
        (let ((rx-result (regexp-exec rx line)))
          (if rx-result
              (match:substring rx-result 1)
              (grep rx port))))))

(define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
  "Setup the compiler environment."
  (let* ((haskell (assoc-ref inputs "haskell"))
         (name-version (package-name-version haskell)))
    (cond
     ((string-match "ghc" name-version)
      (make-ghc-package-database system inputs outputs))
     (else
      (format #t
              "Compiler ~a not supported~%" name-version)))))

;;; TODO: Move this to (guix build utils)?
(define-syntax-rule (with-null-error-port exp)
  "Evaluate EXP with the error port pointing to the bit bucket."
  (with-error-to-port (%make-void-port "w")
    (lambda () exp)))

(define (make-ghc-package-database system inputs outputs)
  "Generate the GHC package database."
  (let* ((haskell  (assoc-ref inputs "haskell"))
         (input-dirs (match inputs
                       (((_ . dir) ...)
                        dir)
                       (_ '())))
         ;; Silence 'find-files' (see 'evaluate-search-paths')
         (conf-dirs (with-null-error-port
                     (search-path-as-list
                      `(,(string-append "lib/" (package-name-version haskell)))
                      input-dirs #:pattern ".*\\.conf.d$")))
         (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
    (mkdir-p %tmp-db-dir)
    (for-each (lambda (file)
                (let ((dest (string-append %tmp-db-dir "/" (basename file))))
                  (unless (file-exists? dest)
                    (copy-file file dest))))
              conf-files)
    (zero? (system* "ghc-pkg"
                    (string-append "--package-db=" %tmp-db-dir)
                    "recache"))))

(define* (register #:key name system inputs outputs #:allow-other-keys)
  "Generate the compiler registration and binary package database files for a
given Haskell package."

  (define (conf-depends conf-file)
    ;; Return a list of pkg-ids from the "depends" field in CONF-FILE
    (let ((port (open-input-file conf-file))
          (field-rx (make-regexp "^(.*):")))
      (let loop ((collecting #f)
                 (deps '()))
        (let* ((line (read-line port))
               (field (and=> (and (not (eof-object? line))
                                  (regexp-exec field-rx line))
                             (cut match:substring <> 1))))
          (cond
           ((and=> field (cut string=? <> "depends"))
            ;; The first dependency is listed on the same line as "depends:",
            ;; so drop those characters.  A line may list more than one .conf.
            (let ((d (string-tokenize (string-drop line 8))))
              (loop #t (append d deps))))
           ((or (eof-object? line) (and collecting field))
            (begin
              (close-port port)
              (reverse! deps)))
           (collecting
            (loop #t (append (string-tokenize line) deps)))
           (else (loop #f deps)))))))

  (define (install-transitive-deps conf-file src dest)
    ;; Copy .conf files from SRC to DEST for dependencies in CONF-FILE, and
    ;; their dependencies, etc.
    (let loop ((seen vlist-null)
               (lst (conf-depends conf-file)))
      (match lst
        (() #t)                         ;done
        ((id . tail)
         (if (not (vhash-assoc id seen))
             (let ((dep-conf  (string-append src  "/" id ".conf"))
                   (dep-conf* (string-append dest "/" id ".conf")))
               (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead?
               (loop (vhash-cons id #t seen)
                     (append lst (conf-depends dep-conf))))
             (loop seen tail))))))

  (let* ((out (assoc-ref outputs "out"))
         (haskell  (assoc-ref inputs "haskell"))
         (lib (string-append out "/lib"))
         (config-dir (string-append lib "/"
                                    (package-name-version haskell)
                                    "/" name ".conf.d"))
         (id-rx (make-regexp "^id: *(.*)$"))
         (config-file (string-append out "/" name ".conf"))
         (params
          (list (string-append "--gen-pkg-config=" config-file))))
    (run-setuphs "register" params)
    ;; The conf file is created only when there is a library to register.
    (or (not (file-exists? config-file))
        (begin
          (mkdir-p config-dir)
          (let* ((config-file-name+id
                  (call-with-ascii-input-file config-file (cut grep id-rx <>))))
            (install-transitive-deps config-file %tmp-db-dir config-dir)
            (rename-file config-file
                         (string-append config-dir "/"
                                        config-file-name+id ".conf"))
            (zero? (system* "ghc-pkg"
                            (string-append "--package-db=" config-dir)
                            "recache")))))))

(define* (check #:key tests? test-target #:allow-other-keys)
  "Run the test suite of a given Haskell package."
  (if tests?
      (run-setuphs test-target '())
      (begin
        (format #t "test suite not run~%")
        #t)))

(define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys)
  "Run the test suite of a given Haskell package."
  (if haddock?
      (run-setuphs "haddock" haddock-flags)
      #t))

(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys)
  (when cabal-revision
    ;; Cabal requires there to be a single file with the suffix ".cabal".
    (match (scandir "." (cut string-suffix? ".cabal" <>))
      ((original)
       (format #t "replacing ~s with ~s~%" original cabal-revision)
       (copy-file cabal-revision original))
      (_ (error "Could not find a Cabal file to patch."))))
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'unpack 'patch-cabal-file patch-cabal-file)
    (delete 'bootstrap)
    (add-before 'configure 'setup-compiler setup-compiler)
    (add-before 'install 'haddock haddock)
    (add-after 'install 'register register)
    (replace 'install install)
    (replace 'check check)
    (replace 'build build)
    (replace 'configure configure)))

(define* (haskell-build #:key inputs (phases %standard-phases)
                        #:allow-other-keys #:rest args)
  "Build the given Haskell package, applying all of PHASES in order."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         args))

;;; haskell-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.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 hg)
  #:use-module (guix build utils)
  #:export (hg-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix hg-download).  It allows a
;;; Mercurial repository to be cloned and checked out at a specific changeset
;;; identifier.
;;;
;;; Code:

(define* (hg-fetch url changeset directory
                   #:key (hg-command "hg"))
  "Fetch CHANGESET from URL into DIRECTORY.  CHANGESET must be a valid
Mercurial changeset identifier.  Return #t on success, #f otherwise."

  (invoke hg-command
          "clone" url
          "--rev" changeset
          ;; Disable TLS certificate verification.  The hash of
          ;; the checkout is known in advance anyway.
          "--insecure"
          directory)

  ;; The contents of '.hg' vary as a function of the current
  ;; status of the Mercurial repo.  Since we want a fixed
  ;; output, this directory needs to be taken out.
  (with-directory-excursion directory
    (delete-file-recursively ".hg"))

  #t)

;;; hg.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 java-utils)
  #:use-module (guix build utils)
  #:export (ant-build-javadoc
            install-jars
            install-javadoc))

;; Copied from haskell-build-system.scm
(define (package-name-version store-dir)
  "Given a store directory STORE-DIR return 'name-version' of the package."
  (let* ((base (basename store-dir)))
    (string-drop base (+ 1 (string-index base #\-)))))

(define* (ant-build-javadoc #:key (target "javadoc") (make-flags '())
                            #:allow-other-keys)
  (apply invoke `("ant" ,target ,@make-flags)))

(define* (install-jars jar-directory)
  "Install jar files from JAR-DIRECTORY to the default target directory.  This
is used in case the build.xml does not include an install target."
  (lambda* (#:key outputs #:allow-other-keys)
    (let ((share (string-append (assoc-ref outputs "out")
                                "/share/java")))
      (for-each (lambda (f) (install-file f share))
                (find-files jar-directory "\\.jar$"))
      #t)))

(define* (install-javadoc apidoc-directory)
  "Install the APIDOC-DIRECTORY to the target directory.  This is used to
install javadocs when this is not done by the install target."
  (lambda* (#:key outputs #:allow-other-keys)
    (let* ((out (assoc-ref outputs "out"))
           (docs (string-append (or (assoc-ref outputs "doc") out)
                                "/share/doc/" (package-name-version out) "/")))
      (mkdir-p docs)
      (copy-recursively apidoc-directory docs)
      #t)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; 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 lisp-utils)
  #:use-module (ice-9 format)
  #:use-module (ice-9 hash-table)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (guix build utils)
  #:export (%lisp
            %lisp-type
            %source-install-prefix
            lisp-eval-program
            compile-system
            test-system
            replace-escaped-macros
            generate-executable-wrapper-system
            generate-executable-entry-point
            generate-executable-for-system
            %bundle-install-prefix
            bundle-asd-file
            wrap-output-translations
            prepend-to-source-registry
            build-program
            build-image
            make-asd-file
            valid-char-set
            normalize-string
            library-output))

;;; Commentary:
;;;
;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
;;; systems for executables. Compile, test, and produce images for systems and
;;; programs, and link them with their dependencies.
;;;
;;; Code:

(define %lisp
  ;; File name of the Lisp compiler.
  (make-parameter "lisp"))

(define %lisp-type
  ;; String representing the class of implementation being used.
  (make-parameter "lisp"))

;; The common parent for Lisp source files, as will as the symbolic
;; link farm for system definition (.asd) files.
(define %source-install-prefix "/share/common-lisp")

(define (%bundle-install-prefix)
  (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))

(define (library-output outputs)
  "If a `lib' output exists, build things there. Otherwise use `out'."
  (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))

;; See nix/libstore/store-api.cc#checkStoreName.
(define valid-char-set
  (string->char-set
   "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))

(define (normalize-string str)
  "Replace invalid characters in STR with a hyphen."
  (string-join (string-tokenize str valid-char-set) "-"))

(define (normalize-dependency dependency)
  "Normalize the name of DEPENDENCY.  Handles dependency definitions of the
dependency-def form described by
<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
Assume that any symbols in DEPENDENCY will be in upper-case."
  (match dependency
    ((':VERSION name rest ...)
     `(:version ,(normalize-string name) ,@rest))
    ((':FEATURE feature-specification dependency-specification)
     `(:feature
       ,feature-specification
       ,(normalize-dependency dependency-specification)))
    ((? string? name) (normalize-string name))
    (require-specification require-specification)))

(define (inputs->asd-file-map inputs)
  "Produce a hash table of the form (system . asd-file), where system is the
name of an ASD system, and asd-file is the full path to its definition."
  (alist->hash-table
   (filter-map
    (match-lambda
      ((_ . path)
       (let ((prefix (string-append path (%bundle-install-prefix))))
         (and (directory-exists? prefix)
              (match (find-files prefix "\\.asd$")
                ((asd-file)
                 (cons
                  (string-drop-right (basename asd-file) 4) ; drop ".asd"
                  asd-file))
                (_ #f))))))
    inputs)))

(define (wrap-output-translations translations)
  `(:output-translations
    ,@translations
    :inherit-configuration))

(define (lisp-eval-program program)
  "Evaluate PROGRAM with a given LISP implementation."
  (define invocation (lisp-invocation program))
  (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation)
  (apply invoke invocation))

(define (spread-statements program argument-name)
  "Return a list with the statements from PROGRAM spread between
ARGUMENT-NAME, a string representing the argument a lisp implementation uses
to accept statements to be evaluated before starting."
  (append-map (lambda (statement)
                (list argument-name (format #f "~S" statement)))
              program))

(define (lisp-invocation program)
  "Return a list of arguments for system* determining how to invoke LISP
with PROGRAM."
  (match (%lisp-type)
    ("sbcl" `(,(%lisp) "--non-interactive"
              ,@(spread-statements program "--eval")))
    ("ecl" `(,(%lisp)
             ,@(spread-statements program "--eval")
             "--eval" "(quit)"))
    (_ (error "The LISP provided is not supported at this time."))))

(define (asdf-load-all systems)
  (map (lambda (system)
         `(asdf:load-system ,system))
       systems))

(define (compile-system system asd-file)
  "Use a lisp implementation to compile SYSTEM using asdf.  Load ASD-FILE
first."
  (lisp-eval-program
   `((require :asdf)
     (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
     (asdf:operate 'asdf:compile-bundle-op ,system))))

(define (system-dependencies system asd-file)
  "Return the dependencies of SYSTEM, as reported by
asdf:system-depends-on.  First load the system's ASD-FILE."
  (define deps-file ".deps.sexp")
  (define program
    `((require :asdf)
      (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
      (with-open-file
       (stream ,deps-file :direction :output)
       (format stream
               "~s~%"
               (asdf:system-depends-on
                (asdf:find-system ,system))))))

  (dynamic-wind
    (lambda _
      (lisp-eval-program program))
    (lambda _
      (call-with-input-file deps-file read))
    (lambda _
      (when (file-exists? deps-file)
        (delete-file deps-file)))))

(define (compiled-system system)
  (let ((system (basename system))) ; this is how asdf handles slashes
    (match (%lisp-type)
      ("sbcl" (string-append system "--system"))
      (_ system))))

(define* (generate-system-definition system
                                     #:key version dependencies)
  `(asdf:defsystem
    ,(normalize-string system)
    :class asdf/bundle:prebuilt-system
    :version ,version
    :depends-on ,dependencies
    :components ((:compiled-file ,(compiled-system system)))
    ,@(if (string=? "ecl" (%lisp-type))
          `(:lib ,(string-append system ".a"))
          '())))

(define (test-system system asd-file test-asd-file)
  "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILE first.
Also load TEST-ASD-FILE if necessary."
  (lisp-eval-program
   `((require :asdf)
     (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
     ,@(if test-asd-file
           `((asdf:load-asd (truename ,test-asd-file)))
           ;; Try some likely files.
           (map (lambda (file)
                  `(when (uiop:file-exists-p ,file)
                     (asdf:load-asd (truename ,file))))
                (list
                 (string-append system "-tests.asd")
                 (string-append system "-test.asd")
                 "tests.asd"
                 "test.asd")))
     (asdf:test-system ,system))))

(define (string->lisp-keyword . strings)
  "Return a lisp keyword for the concatenation of STRINGS."
  (string->symbol (apply string-append ":" strings)))

(define (generate-executable-for-system type system)
  "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
'asdf:program-op.  The latter will always be standalone.  Depends on having
created a \"SYSTEM-exec\" system which contains the entry program."
  (lisp-eval-program
   `((require :asdf)
     (asdf:operate ',type ,(string-append system "-exec")))))

(define (generate-executable-wrapper-system system dependencies)
  "Generates a system which can be used by asdf to produce an image or program
inside the current directory.  The image or program will contain
DEPENDENCIES."
  (with-output-to-file (string-append system "-exec.asd")
    (lambda _
      (format #t "~y~%"
              `(defsystem ,(string->lisp-keyword system "-exec")
                 :entry-point ,(string-append system "-exec:main")
                 :depends-on (:uiop
                              ,@(map string->lisp-keyword
                                     dependencies))
                 :components ((:file ,(string-append system "-exec"))))))))

(define (generate-executable-entry-point system entry-program)
  "Generates an entry point program from the list of lisp statements
ENTRY-PROGRAM for SYSTEM within the current directory."
  (with-output-to-file (string-append system "-exec.lisp")
    (lambda _
      (let ((system (string->lisp-keyword system "-exec")))
        (format #t "~{~y~%~%~}"
                `((defpackage ,system
                    (:use :cl)
                    (:export :main))

                  (in-package ,system)

                  (defun main ()
                    (let ((arguments uiop:*command-line-arguments*))
                      (declare (ignorable arguments))
                      ,@entry-program))))))))

(define (generate-dependency-links registry system)
  "Creates a program which populates asdf's source registry from REGISTRY, an
alist of dependency names to corresponding asd files.  This allows the system
to locate its dependent systems."
  `(progn
    (asdf/source-registry:ensure-source-registry)
    ,@(map (match-lambda
             ((name . asd-file)
              `(setf
                (gethash ,name
                         asdf/source-registry:*source-registry*)
                ,(string->symbol "#p")
                ,asd-file)))
           registry)))

(define* (make-asd-file asd-file
                        #:key system version inputs
                        (system-asd-file #f))
  "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
  (define dependencies
    (let ((deps
           (system-dependencies system system-asd-file)))
      (if (eq? 'NIL deps)
          '()
          (map normalize-dependency deps))))

  (define lisp-input-map
    (inputs->asd-file-map inputs))

  (define dependency-name
    (match-lambda
      ((':version name _ ...) name)
      ((':feature _ dependency-specification)
       (dependency-name dependency-specification))
      ((? string? name) name)
      (_ #f)))

  (define registry
    (filter-map hash-get-handle
                (make-list (length dependencies)
                           lisp-input-map)
                (map dependency-name dependencies)))

  (call-with-output-file asd-file
    (lambda (port)
      (display
       (replace-escaped-macros
        (format #f "~y~%~y~%"
                (generate-system-definition system
                                            #:version version
                                            #:dependencies dependencies)
                (generate-dependency-links registry system)))
       port))))

(define (bundle-asd-file output-path original-asd-file)
  "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd.  Returns two
values: the asd file itself and the directory in which it resides."
  (let ((bundle-asd-path (string-append output-path
                                        (%bundle-install-prefix))))
    (values (string-append bundle-asd-path "/" (basename original-asd-file))
            bundle-asd-path)))

(define (replace-escaped-macros string)
  "Replace simple lisp forms that the guile writer escapes, for example by
replacing #{#p}# with #p.  Should only be used to replace truly simple forms
which are not nested."
  (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
                            'pre 2 'post))

(define (prepend-to-source-registry path)
  (setenv "CL_SOURCE_REGISTRY"
          (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))

(define* (build-program program outputs #:key
                        (dependency-prefixes (list (library-output outputs)))
                        (dependencies (list (basename program)))
                        entry-program
                        #:allow-other-keys)
  "Generate an executable program containing all DEPENDENCIES, and which will
execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
has been bound to the command-line arguments which were passed.  Link in any
asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
retained."
  (generate-executable program
                       #:dependencies dependencies
                       #:dependency-prefixes dependency-prefixes
                       #:entry-program entry-program
                       #:type 'asdf:program-op)
  (let* ((name (basename program))
         (bin-directory (dirname program)))
    (with-directory-excursion bin-directory
      (rename-file (string-append name "-exec")
                   name)))
  #t)

(define* (build-image image outputs #:key
                      (dependency-prefixes (list (library-output outputs)))
                      (dependencies (list (basename image)))
                      #:allow-other-keys)
  "Generate an image, possibly standalone, which contains all DEPENDENCIES,
placing the result in IMAGE.image.  Link in any asd files from
DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
  (generate-executable image
                       #:dependencies dependencies
                       #:dependency-prefixes dependency-prefixes
                       #:entry-program '(nil)
                       #:type 'asdf:image-op)
  (let* ((name (basename image))
         (bin-directory (dirname image)))
    (with-directory-excursion bin-directory
      (rename-file (string-append name "-exec--all-systems.image")
                   (string-append name ".image"))))
  #t)

(define* (generate-executable out-file #:key
                              dependencies
                              dependency-prefixes
                              entry-program
                              type
                              #:allow-other-keys)
  "Generate an executable by using asdf operation TYPE, containing whithin the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
executable.  Link in any asd files from DEPENDENCY-PREFIXES to ensure
references to those libraries are retained."
  (let* ((bin-directory (dirname out-file))
         (name (basename out-file)))
    (mkdir-p bin-directory)
    (with-directory-excursion bin-directory
      (generate-executable-wrapper-system name dependencies)
      (generate-executable-entry-point name entry-program))

    (prepend-to-source-registry
     (string-append bin-directory "/"))

    (setenv "ASDF_OUTPUT_TRANSLATIONS"
            (replace-escaped-macros
             (format
              #f "~S"
              (wrap-output-translations
               `(((,bin-directory :**/ :*.*.*)
                  (,bin-directory :**/ :*.*.*)))))))

    (generate-executable-for-system type name)

    (let* ((after-store-prefix-index
            (string-index out-file #\/
                          (1+ (string-length (%store-directory)))))
           (output (string-take out-file after-store-prefix-index))
           (hidden-asd-links (string-append output "/.asd-files")))

      (mkdir-p hidden-asd-links)
      (for-each
       (lambda (path)
         (for-each
          (lambda (asd-file)
            (symlink asd-file
                     (string-append hidden-asd-links
                                    "/" (basename asd-file))))
          (find-files (string-append path (%bundle-install-prefix))
                      "\\.asd$")))
       dependency-prefixes))

    (delete-file (string-append bin-directory "/" name "-exec.asd"))
    (delete-file (string-append bin-directory "/" name "-exec.lisp"))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.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 make-bootstrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (guix build utils)
  #:export (make-stripped-libc))

;; Commentary:
;;
;; This module provides facilities to build the bootstrap binaries.
;;
;; Code:

(define (make-stripped-libc output libc kernel-headers)
  "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed
when producing a bootstrap libc."

  (define (copy-mach-headers output kernel-headers)
    (let* ((incdir (string-append output "/include")))
      (copy-recursively (string-append libc "/include") incdir)

      (copy-recursively (string-append kernel-headers "/include/mach")
                        (string-append incdir "/mach"))
      #t))

  (define (copy-linux-headers output kernel-headers)
    (let* ((incdir (string-append output "/include")))
      (copy-recursively (string-append libc "/include") incdir)

      ;; Copy some of the Linux-Libre headers that glibc headers
      ;; refer to.
      (mkdir (string-append incdir "/linux"))
      (for-each (lambda (file)
                  (install-file (string-append kernel-headers "/include/linux/" file)
                                (string-append incdir "/linux")))
                '("limits.h" "errno.h" "socket.h" "kernel.h"
                  "sysctl.h" "param.h" "ioctl.h" "types.h"
                  "posix_types.h" "stddef.h" "falloc.h"))

      (copy-recursively (string-append kernel-headers "/include/asm")
                        (string-append incdir "/asm"))
      (copy-recursively (string-append kernel-headers "/include/asm-generic")
                        (string-append incdir "/asm-generic"))
      #t))

  (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\
util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\
_nonshared\\.a)$")

  (setvbuf (current-output-port) _IOLBF)
  (let* ((libdir (string-append output "/lib")))
    (mkdir-p libdir)
    (for-each (lambda (file)
                (let ((target (string-append libdir "/"
                                             (basename file))))
                  (copy-file file target)
                  (remove-store-references target)))
              (find-files (string-append libc "/lib") %libc-object-files-rx))
    #t)

    (if (directory-exists? (string-append kernel-headers "/include/mach"))
        (copy-mach-headers output kernel-headers)
        (copy-linux-headers output kernel-headers)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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 meson-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:)
  #:use-module (guix build utils)
  #:use-module (guix build rpath)
  #:use-module (guix build gremlin)
  #:use-module (guix elf)
  #:use-module (ice-9 match)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:export (%standard-phases
            meson-build))

;; Commentary:
;;
;; Builder-side code of the standard meson build procedure.
;;
;; Code:

(define* (configure #:key outputs configure-flags build-type
                    #:allow-other-keys)
  "Configure the given package."
  (let* ((out (assoc-ref outputs "out"))
         (source-dir (getcwd))
         (build-dir "../build")
         (prefix (assoc-ref outputs "out"))
         (args `(,(string-append "--prefix=" prefix)
                 ,(string-append "--buildtype=" build-type)
                 ,(string-append "-Dc_link_args=-Wl,-rpath="
                                 (assoc-ref outputs "out") "/lib")
                 ,(string-append "-Dcpp_link_args=-Wl,-rpath="
                                 (assoc-ref outputs "out") "/lib")
                 ,@configure-flags
                 ,source-dir)))

    (mkdir build-dir)
    (chdir build-dir)
    (apply invoke "meson" args)))

(define* (build #:key parallel-build?
                #:allow-other-keys)
  "Build a given meson package."
  (invoke "ninja" "-j" (if parallel-build?
                           (number->string (parallel-job-count))
                           "1")))

(define* (check #:key test-target parallel-tests? tests?
                #:allow-other-keys)
  (setenv "MESON_TESTTHREADS"
          (if parallel-tests?
              (number->string (parallel-job-count))
              "1"))
  (if tests?
      (invoke "ninja" test-target)
      (begin
        (format #t "test suite not run~%")
        #t)))

(define* (install #:rest args)
  (invoke "ninja" "install"))

(define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec"
                                               "bin" "sbin"))
                      outputs #:allow-other-keys)
  "Try to make sure all ELF files in ELF-DIRECTORIES are able to find their
local dependencies in their RUNPATH, by searching for the needed libraries in
the directories of the package, and adding them to the RUNPATH if needed.
Also shrink the RUNPATH to what is needed,
since a lot of directories are left over from the build phase of meson,
for example libraries only needed for the tests."

  ;; Find the directories (if any) that contains DEP-NAME.  The directories
  ;; searched are the ones that ELF-FILES are in.
  (define (find-deps dep-name elf-files)
    (map dirname (filter (lambda (file)
                           (string=? dep-name (basename file)))
                         elf-files)))

  ;; Return a list of libraries that FILE needs.
  (define (file-needed file)
    (let* ((elf (call-with-input-file file
                  (compose parse-elf get-bytevector-all)))
           (dyninfo (elf-dynamic-info elf)))
      (if dyninfo
          (elf-dynamic-info-needed dyninfo)
          '())))

  ;; If FILE needs any libs that are part of ELF-FILES, the RUNPATH
  ;; is modified accordingly.
  (define (handle-file file elf-files)
    (let* ((dep-dirs (concatenate (map (lambda (dep-name)
                                         (find-deps dep-name elf-files))
                                       (file-needed file)))))
      (unless (null? dep-dirs)
        (augment-rpath file (string-join dep-dirs ":")))))

  (define handle-output
    (match-lambda
      ((output . directory)
       (let* ((elf-dirnames (map (lambda (subdir)
                                   (string-append directory "/" subdir))
                                 elf-directories))
              (existing-elf-dirs (filter (lambda (dir)
                                            (and (file-exists? dir)
                                                 (file-is-directory? dir)))
                                          elf-dirnames))
              (elf-pred (lambda (name stat)
                          (elf-file? name)))
              (elf-list (concatenate (map (lambda (dir)
                                            (find-files dir elf-pred))
                                          existing-elf-dirs))))
         (for-each (lambda (elf-file)
                     (invoke "patchelf" "--shrink-rpath" elf-file)
                     (handle-file elf-file elf-list))
                   elf-list)))))
  (for-each handle-output outputs)
  #t)

(define %standard-phases
  ;; The standard-phases of glib-or-gtk contains a superset of the phases
  ;; from the gnu-build-system.  If the glib-or-gtk? key is #f (the default)
  ;; then the extra phases will be removed again in (guix build-system meson).
  (modify-phases glib-or-gtk:%standard-phases
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    ;; XXX: We used to have 'fix-runpath' here, but it appears no longer
    ;; necessary with newer Meson.  However on 'core-updates' there is a
    ;; useful 'strip-runpath' procedure to ensure no bogus directories in
    ;; RUNPATH (remember that we tell Meson to not touch RUNPATH in
    ;; (@ (gnu packages build-tools) meson-for-build)), so it should be
    ;; re-added there sans the augment-rpath calls (which are not needed).
    (replace 'install install)))

(define* (meson-build #:key inputs phases
                      #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; meson-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 minify-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build minify-build-system) #:prefix minify:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 popen)
  #:export (%standard-phases
            minify-build
            minify))

;; Commentary:
;;
;; Builder-side code of the standard minification procedure for JavaScript
;; files.
;;
;; Code:

(define* (minify file #:key target (directory ""))
  (format #t "minifying ~a\n" file)
  (let* ((base (basename file ".js"))
         (installed (or target (string-append directory base ".min.js")))
         (minified (open-pipe* OPEN_READ "uglify-js" file)))
    (call-with-output-file installed
      (cut dump-port minified <>))
    #t))

(define* (build #:key javascript-files
                #:allow-other-keys)
  (let ((files (or javascript-files
                   (find-files "src" "\\.js$"))))
    (mkdir-p "guix/build")
    (every (cut minify <> #:directory "guix/build/") files)))

(define* (install #:key outputs #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out"))
         (js  (string-append out "/share/javascript/")))
    (mkdir-p js)
    (for-each (cut install-file <> js)
              (find-files "guix/build" "\\.min\\.js$")))
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (replace 'build build)
    (delete 'check)
    (replace 'install install)))

(define* (minify-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
  "Build the given JavaScript package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; minify-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 ocaml-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            ocaml-build))

;; Commentary:
;;
;; Builder-side code of the standard ocaml build procedure.
;;
;; Code:

(define* (ocaml-findlib-environment #:key outputs #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out")))
    (setenv "OCAMLFIND_DESTDIR" (string-append out "/lib/ocaml/site-lib"))
    (setenv "OCAMLFIND_LDCONF" "ignore"))
  #t)

(define* (configure #:key outputs (configure-flags '())
                    (test-flags '("--enable-tests")) tests?
                    #:allow-other-keys)
  "Configure the given package."
  (let* ((out        (assoc-ref outputs "out")))
    (format #t "build directory: ~s~%" (getcwd))
    (if (file-exists? "setup.ml")
      (let ((args `("-configure"
                    "--prefix" ,out
                    ,@(if tests?
                          test-flags
                          '())
                    ,@configure-flags)))
        (format #t "running 'setup.ml' with arguments ~s~%" args)
        (zero? (apply system* "ocaml" "setup.ml" args)))
       (let ((args `("-prefix" ,out ,@configure-flags)))
        (format #t "running 'configure' with arguments ~s~%" args)
        (zero? (apply system* "./configure" args))))))

(define* (build #:key inputs outputs (build-flags '()) (make-flags '())
                (use-make? #f) #:allow-other-keys)
  "Build the given package."
  (if (and (file-exists? "setup.ml") (not use-make?))
    (zero? (apply system* "ocaml" "setup.ml" "-build" build-flags))
    (if (file-exists? "Makefile")
      (zero? (apply system* "make" make-flags))
      (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml")))
        (zero? (apply system* "ocaml" "-I"
                              (string-append (assoc-ref inputs "findlib")
                                             "/lib/ocaml/site-lib")
                              file build-flags))))))

(define* (check #:key inputs outputs (make-flags '()) (test-target "test") tests?
                  (use-make? #f) #:allow-other-keys)
  "Install the given package."
  (when tests?
    (if (and (file-exists? "setup.ml") (not use-make?))
      (zero? (system* "ocaml" "setup.ml" (string-append "-" test-target)))
      (if (file-exists? "Makefile")
        (zero? (apply system* "make" test-target make-flags))
        (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml")))
          (zero? (system* "ocaml" "-I"
                          (string-append (assoc-ref inputs "findlib")
                                         "/lib/ocaml/site-lib")
                          file test-target)))))))

(define* (install #:key outputs (build-flags '()) (make-flags '()) (use-make? #f)
                  (install-target "install")
                  #:allow-other-keys)
  "Install the given package."
  (let ((out (assoc-ref outputs "out")))
    (if (and (file-exists? "setup.ml") (not use-make?))
      (zero? (apply system* "ocaml" "setup.ml"
                    (string-append "-" install-target) build-flags))
      (if (file-exists? "Makefile")
        (zero? (apply system* "make" install-target make-flags))
        (zero? (system* "opam-installer" "-i" (string-append "--prefix=" out)
                        (string-append "--libdir=" out "/lib/ocaml/site-lib")))))))

(define* (prepare-install #:key outputs #:allow-other-keys)
  "Prepare for building the given package."
  (mkdir-p (string-append (assoc-ref outputs "out") "/lib/ocaml/site-lib"))
  (mkdir-p (string-append (assoc-ref outputs "out") "/bin")))

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (add-before 'configure 'ocaml-findlib-environment
                ocaml-findlib-environment)
    (add-before 'install 'prepare-install prepare-install)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

(define* (ocaml-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; ocaml-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.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 perl-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            perl-build))

;; Commentary:
;;
;; Builder-side code of the standard Perl package build procedure.
;;
;; Code:

(define* (configure #:key outputs make-maker?
                    (make-maker-flags '()) (module-build-flags '())
                    #:allow-other-keys)
  "Configure the given Perl package."
  (let* ((out (assoc-ref outputs "out"))
         (args (cond
                ;; Prefer to use Module::Build unless otherwise told
                ((and (file-exists? "Build.PL")
                      (not make-maker?))
                 `("Build.PL" ,(string-append "--prefix=" out)
                   "--installdirs=site" ,@module-build-flags))
                ((file-exists? "Makefile.PL")
                 `("Makefile.PL" ,(string-append "PREFIX=" out)
                   ;; Prevent installation of 'perllocal.pod' files for
                   ;; determinism.  These are typically used to build a
                   ;; catalogue of installed packages, but does not provide
                   ;; any useful information when installed with a module.
                   "INSTALLDIRS=site" "NO_PERLLOCAL=1" ,@make-maker-flags))
                (else (error "no Build.PL or Makefile.PL found")))))
    (format #t "running `perl' with arguments ~s~%" args)
    (apply invoke "perl" args)))

(define-syntax-rule (define-w/gnu-fallback* (name args ...) body ...)
  (define* (name args ... #:rest rest)
    (if (access? "Build" X_OK)
        (begin body ...)
        (apply (assoc-ref gnu:%standard-phases 'name) rest))))

(define-w/gnu-fallback* (build)
  (invoke "./Build"))

(define-w/gnu-fallback* (check #:key target
                               (tests? (not target)) (test-flags '())
                               #:allow-other-keys)
  (if tests?
      (apply invoke "./Build" "test" test-flags)
      (format #t "test suite not run~%"))
  #t)

(define-w/gnu-fallback* (install)
  (invoke "./Build" "install"))

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure',
  ;; `build', `check', and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'install install)
    (replace 'check check)
    (replace 'build build)
    (replace 'configure configure)))

(define* (perl-build #:key inputs (phases %standard-phases)
                     #:allow-other-keys #:rest args)
  "Build the given Perl package, applying all of PHASES in order."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         args))

;;; perl-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.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 profiles)
  #:use-module (guix build union)
  #:use-module (guix build utils)
  #:use-module (guix search-paths)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:re-export (symlink-relative)                  ;for convenience
  #:export (ensure-writable-directory
            build-profile))

;;; Commentary:
;;;
;;; Build a user profile (essentially the union of all the installed packages)
;;; with its associated meta-data.
;;;
;;; Code:

(define (abstract-profile profile)
  "Return a procedure that replaces PROFILE in VALUE with a reference to the
'GUIX_PROFILE' environment variable.  This allows users to specify what the
user-friendly name of the profile is, for instance ~/.guix-profile rather than
/gnu/store/...-profile."
  (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))
        (crop        (cute string-drop <> (string-length profile))))
    (match-lambda
      ((search-path . value)
       (match (search-path-specification-separator search-path)
         (#f
          (cons search-path
                (string-append replacement (crop value))))
         ((? string? separator)
          (let ((items (string-tokenize* value separator)))
            (cons search-path
                  (string-join (map (lambda (str)
                                      (string-append replacement (crop str)))
                                    items)
                               separator)))))))))

(define (write-environment-variable-definition port)
  "Write the given environment variable definition to PORT."
  (match-lambda
    ((search-path . value)
     (display (search-path-definition search-path value #:kind 'prefix)
              port)
     (newline port))))

(define (build-etc/profile output search-paths)
  "Build the 'OUTPUT/etc/profile' shell file containing environment variable
definitions for all the SEARCH-PATHS."
  (mkdir-p (string-append output "/etc"))
  (call-with-output-file (string-append output "/etc/profile")
    (lambda (port)
      ;; The use of $GUIX_PROFILE described below is not great.  Another
      ;; option would have been to use "$1" and have users run:
      ;;
      ;;   source ~/.guix-profile/etc/profile ~/.guix-profile
      ;;
      ;; However, when 'source' is used with no arguments, $1 refers to the
      ;; first positional parameter of the calling script, so we cannot rely
      ;; on it.
      (display "\
# Source this file to define all the relevant environment variables in Bash
# for this profile.  You may want to define the 'GUIX_PROFILE' environment
# variable to point to the \"visible\" name of the profile, like this:
#
#  GUIX_PROFILE=/path/to/profile ; \\
#  source /path/to/profile/etc/profile
#
# When GUIX_PROFILE is undefined, the various environment variables refer
# to this specific profile generation.
\n" port)
      (let ((variables (evaluate-search-paths search-paths
                                              (list output))))
        (for-each (write-environment-variable-definition port)
                  (map (abstract-profile output) variables))))))

(define* (ensure-writable-directory directory
                                    #:key (symlink symlink))
  "Ensure DIRECTORY exists and is writable.  If DIRECTORY is currently a
symlink (to a read-only directory in the store), then delete the symlink and
instead make DIRECTORY a \"real\" directory containing symlinks."
  (define (absolute? file)
    (string-prefix? "/" file))

  (define (unsymlink link)
    (let* ((target (match (readlink link)
                     ((? absolute? target)
                      target)
                     ((? string? relative)
                      (string-append (dirname link) "/" relative))))
           ;; TARGET might itself be a symlink, so append "/" to make sure
           ;; 'scandir' enters it.
           (files  (scandir (string-append target "/")
                            (negate (cut member <> '("." ".."))))))
      (delete-file link)
      (mkdir link)
      (for-each (lambda (file)
                  (symlink (string-append target "/" file)
                           (string-append link "/" file)))
                files)))

  (catch 'system-error
    (lambda ()
      (mkdir directory))
    (lambda args
      (let ((errno (system-error-errno args)))
        (if (= errno EEXIST)
            (let ((stat (lstat directory)))
              (case (stat:type stat)
                ((symlink)
                 ;; "Unsymlink" DIRECTORY so that it is writable.
                 (unsymlink directory))
                ((directory)
                 #t)
                (else
                 (error "cannot mkdir because a same-named file exists"
                        directory))))
            (apply throw args))))))

(define* (build-profile output inputs
                        #:key manifest search-paths
                        (symlink symlink))
  "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to
create symlinks.  Write MANIFEST, an sexp, to OUTPUT/manifest.  Create
OUTPUT/etc/profile with Bash definitions for -all the variables listed in
SEARCH-PATHS."
  ;; Make the symlinks.
  (union-build output inputs
               #:symlink symlink
               #:log-port (%make-void-port "w"))

  ;; Store meta-data.
  (call-with-output-file (string-append output "/manifest")
    (lambda (p)
      (pretty-print manifest p)))

  ;; Make sure we can write to 'OUTPUT/etc'.  'union-build' above could have
  ;; made 'etc' a symlink to a read-only sub-directory in the store so we need
  ;; to work around that.
  (ensure-writable-directory (string-append output "/etc")
                             #:symlink symlink)

  ;; Write 'OUTPUT/etc/profile'.
  (build-etc/profile output search-paths))

;;; profile.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; 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 pull)
  #:use-module (guix modules)
  #:use-module (guix build utils)
  #:use-module (guix build compile)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:export (build-guix))

;;; Commentary:
;;;
;;; Helpers for the 'guix pull' command to unpack and build Guix.
;;;
;;; Code:

(define (has-all-its-dependencies? file)
  "Return true if the dependencies of the module defined in FILE are
available, false otherwise."
  (let ((module (call-with-input-file file
                  (lambda (port)
                    (match (read port)
                      (('define-module name _ ...)
                       name))))))
    ;; If one of the dependencies of MODULE is missing, we get a
    ;; '&missing-dependency-error'.
    (guard (c ((missing-dependency-error? c) #f))
      (source-module-closure (list module) #:select? (const #t)))))

(define (all-scheme-files directory)
  "Return a sorted list of Scheme files found in DIRECTORY."
  ;; Load guix/ modules before gnu/ modules to get somewhat steadier
  ;; progress reporting.
  (sort (filter (cut string-suffix? ".scm" <>)
                (find-files directory "\\.scm"))
        (let ((guix (string-append directory "/guix"))
              (gnu  (string-append directory "/gnu")))
          (lambda (a b)
            (or (and (string-prefix? guix a)
                     (string-prefix? gnu  b))
                (string<? a b))))))

(define* (build-guix out source
                     #:key
                     system
                     storedir localstatedir sysconfdir sbindir

                     (package-name "GNU Guix")
                     (package-version "0")
                     (bug-report-address "bug-guix@gnu.org")
                     (home-page-url "https://gnu.org/s/guix")

                     libgcrypt zlib gzip bzip2 xz

                     (debug-port (%make-void-port "w"))
                     (log-port (current-error-port)))
  "Build and install Guix in directory OUT using SOURCE, a directory
containing the source code.  Write any debugging output to DEBUG-PORT."
  (setvbuf (current-output-port) _IOLBF)
  (setvbuf (current-error-port) _IOLBF)

  (with-directory-excursion source
    (format #t "copying and compiling to '~a' with Guile ~a...~%"
            out (version))

    ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
    (copy-recursively "guix" (string-append out "/guix")
                      #:log debug-port)
    (copy-recursively "gnu" (string-append out "/gnu")
                      #:log debug-port)
    (copy-file "guix.scm" (string-append out "/guix.scm"))
    (copy-file "gnu.scm" (string-append out "/gnu.scm"))

    ;; Instantiate a (guix config) module that preserves the original
    ;; settings.
    (copy-file "guix/config.scm.in"
               (string-append out "/guix/config.scm"))
    (substitute* (string-append out "/guix/config.scm")
      (("@PACKAGE_NAME@") package-name)
      (("@PACKAGE_VERSION@") package-version)
      (("@PACKAGE_BUGREPORT@") bug-report-address)
      (("@PACKAGE_URL@") home-page-url)
      (("@storedir@") storedir)
      (("@guix_localstatedir@") localstatedir)
      (("@guix_sysconfdir@") sysconfdir)
      (("@guix_sbindir@") sbindir)
      (("@guix_system@") system)
      (("@LIBGCRYPT@") (string-append libgcrypt "/lib/libgcrypt"))
      (("@LIBZ@") (string-append zlib "/lib/libz"))
      (("@GZIP@") (string-append gzip "/bin/gzip"))
      (("@BZIP2@") (string-append bzip2 "/bin/bzip2"))
      (("@XZ@") (string-append xz "/bin/xz"))
      (("@NIX_INSTANTIATE@") "nix-instantiate"))  ;for (guix import nix)

    ;; Augment the search path so Scheme code can be compiled.
    (set! %load-path (cons out %load-path))
    (set! %load-compiled-path (cons out %load-compiled-path))

    ;; Compile the .scm files.  Hide warnings.
    (parameterize ((current-warning-port (%make-void-port "w")))
      ;; Filter out files depending on Guile-SSH when Guile-SSH is missing.
      (let ((files (filter has-all-its-dependencies?
                           (all-scheme-files out))))
        (compile-files out out files

                       #:workers (parallel-job-count)

                       ;; Disable warnings.
                       #:warning-options '()

                       #:report-load
                       (lambda (file total completed)
                         (display #\cr log-port)
                         (format log-port
                                 "loading...\t~5,1f% of ~d files" ;FIXME: i18n
                                 (* 100. (/ completed total)) total)
                         (force-output log-port)
                         (format debug-port "~%loading '~a'...~%" file))

                       #:report-compilation
                       (lambda (file total completed)
                         (display #\cr log-port)
                         (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
                                 (* 100. (/ completed total)) total)
                         (force-output log-port)
                         (format debug-port "~%compiling '~a'...~%" file))))))

  (newline)
  #t)

;;; pull.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 python-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            add-installed-pythonpath
            site-packages
            python-build))

;; Commentary:
;;
;; Builder-side code of the standard Python package build procedure.
;;
;;
;; Backgound about the Python installation methods
;;
;; In Python there are different ways to install packages: distutils,
;; setuptools, easy_install and pip.  All of these are sharing the file
;; setup.py, introduced with distutils in Python 2.0. The setup.py file can be
;; considered as a kind of Makefile accepting targets (or commands) like
;; "build" and "install".  As of autumn 2016 the recommended way to install
;; Python packages is using pip.
;;
;; For both distutils and setuptools, running "python setup.py install" is the
;; way to install Python packages.  With distutils the "install" command
;; basically copies all packages into <prefix>/lib/pythonX.Y/site-packages.
;;
;; Some time later "setuptools" was established to enhance distutils.  To use
;; setuptools, the developer imports setuptools in setup.py.  When importing
;; setuptools, the original "install" command gets overwritten by setuptools'
;; "install" command.
;;
;; The command-line tools easy_install and pip are both capable of finding and
;; downloading the package source from PyPI (the Python Package Index).  Both
;; of them import setuptools and execute the "setup.py" file under their
;; control.  Thus the "setup.py" behaves as if the developer had imported
;; setuptools within setup.py - even is still using only distutils.
;;
;; Setuptools' "install" command (to be more precise: the "easy_install"
;; command which is called by "install") will put the path of the currently
;; installed version of each package and it's dependencies (as declared in
;; setup.py) into an "easy-install.pth" file.  In Guix each packages gets its
;; own "site-packages" directory and thus an "easy-install.pth" of its own.
;; To avoid conflicts, the python build system renames the file to
;; <packagename>.pth in the phase rename-pth-file.  To ensure that Python will
;; process the .pth file, easy_install also creates a basic "site.py" in each
;; "site-packages" directory.  The file is the same for all packages, thus
;; there is no need to rename it.  For more information about .pth files and
;; the site module, please refere to
;; https://docs.python.org/3/library/site.html.
;;
;; The .pth files contain the file-system paths (pointing to the store) of all
;; dependencies.  So the dependency is hidden in the .pth file but is not
;; visible in the file-system.  Now if packages A and B both required packages
;; P, but in different versions, Guix will not detect this when installing
;; both A and B to a profile. (For details and example see
;; https://lists.gnu.org/archive/html/guix-devel/2016-10/msg01233.html.)
;;
;; Pip behaves a bit different then easy_install: it always executes
;; "setup.py" with the option "--single-version-externally-managed" set.  This
;; makes setuptools' "install" command run the original "install" command
;; instead of the "easy_install" command, so no .pth file (and no site.py)
;; will be created.  The "site-packages" directory only contains the package
;; and the related .egg-info directory.
;;
;; This is exactly what we need for Guix and this is what we mimic in the
;; install phase below.
;;
;; As a draw back, the magic of the .pth file of linking to the other required
;; packages is gone and these packages have now to be declared as
;; "propagated-inputs".
;;
;; Note: Importing setuptools also adds two sub-commands: "install_egg_info"
;; and "install_scripts".  These sub-commands are executed even if
;; "--single-version-externally-managed" is set, thus the .egg-info directory
;; and the scripts defined in entry-points will always be created.

(define setuptools-shim
  ;; Run setup.py with "setuptools" being imported, which will patch
  ;; "distutils". This is needed for packages using "distutils" instead of
  ;; "setuptools" since the former does not understand the
  ;; "--single-version-externally-managed" flag.
  ;; Python code taken from pip 9.0.1 pip/utils/setuptools_build.py
  (string-append
   "import setuptools, tokenize;__file__='setup.py';"
   "f=getattr(tokenize, 'open', open)(__file__);"
   "code=f.read().replace('\\r\\n', '\\n');"
   "f.close();"
   "exec(compile(code, __file__, 'exec'))"))

(define (call-setuppy command params use-setuptools?)
  (if (file-exists? "setup.py")
      (begin
         (format #t "running \"python setup.py\" with command ~s and parameters ~s~%"
                command params)
         (if use-setuptools?
             (apply invoke "python" "-c" setuptools-shim
                    command params)
             (apply invoke "python" "./setup.py" command params)))
      (error "no setup.py found")))

(define* (build #:key use-setuptools? #:allow-other-keys)
  "Build a given Python package."
  (call-setuppy "build" '() use-setuptools?)
  #t)

(define* (check #:key tests? test-target use-setuptools? #:allow-other-keys)
  "Run the test suite of a given Python package."
  (if tests?
      ;; Running `setup.py test` creates an additional .egg-info directory in
      ;; build/lib in some cases, e.g. if the source is in a sub-directory
      ;; (given with `package_dir`). This will by copied to the output, too,
      ;; so we need to remove.
      (let ((before (find-files "build" "\\.egg-info$" #:directories? #t)))
        (call-setuppy test-target '() use-setuptools?)
        (let* ((after (find-files "build" "\\.egg-info$" #:directories? #t))
               (inter (lset-difference string=? after before)))
          (for-each delete-file-recursively inter)))
      (format #t "test suite not run~%"))
  #t)

(define (get-python-version python)
  (let* ((version     (last (string-split python #\-)))
         (components  (string-split version #\.))
         (major+minor (take components 2)))
    (string-join major+minor ".")))

(define (site-packages inputs outputs)
  "Return the path of the current output's Python site-package."
  (let* ((out (assoc-ref outputs "out"))
         (python (assoc-ref inputs "python")))
    (string-append out "/lib/python"
                   (get-python-version python)
                   "/site-packages/")))

(define (add-installed-pythonpath inputs outputs)
  "Prepend the Python site-package of OUTPUT to PYTHONPATH.  This is useful
when running checks after installing the package."
  (let ((old-path (getenv "PYTHONPATH"))
        (add-path (site-packages inputs outputs)))
    (setenv "PYTHONPATH"
            (string-append add-path
                           (if old-path (string-append ":" old-path) "")))
    #t))

(define* (install #:key outputs (configure-flags '()) use-setuptools?
                  #:allow-other-keys)
  "Install a given Python package."
  (let* ((out (assoc-ref outputs "out"))
         (params (append (list (string-append "--prefix=" out))
                         (if use-setuptools?
                             ;; distutils does not accept these flags
                             (list "--single-version-externally-managed"
                                    "--root=/")
                             '())
                         configure-flags)))
    (call-setuppy "install" params use-setuptools?)
    #t))

(define* (wrap #:key inputs outputs #:allow-other-keys)
  (define (list-of-files dir)
    (map (cut string-append dir "/" <>)
         (or (scandir dir (lambda (f)
                            (let ((s (stat (string-append dir "/" f))))
                              (eq? 'regular (stat:type s)))))
             '())))

  (define bindirs
    (append-map (match-lambda
                 ((_ . dir)
                  (list (string-append dir "/bin")
                        (string-append dir "/sbin"))))
                outputs))

  (let* ((out  (assoc-ref outputs "out"))
         (python (assoc-ref inputs "python"))
         (var `("PYTHONPATH" prefix
                ,(cons (string-append out "/lib/python"
                                      (get-python-version python)
                                      "/site-packages")
                       (search-path-as-string->list
                        (or (getenv "PYTHONPATH") ""))))))
    (for-each (lambda (dir)
                (let ((files (list-of-files dir)))
                  (for-each (cut wrap-program <> var)
                            files)))
              bindirs)
    #t))

(define* (rename-pth-file #:key name inputs outputs #:allow-other-keys)
  "Rename easy-install.pth to NAME.pth to avoid conflicts between packages
installed with setuptools."
  ;; Even if the "easy-install.pth" is not longer created, we kept this phase.
  ;; There still may be packages creating an "easy-install.pth" manually for
  ;; some good reason.
  (let* ((out (assoc-ref outputs "out"))
         (python (assoc-ref inputs "python"))
         (site-packages (string-append out "/lib/python"
                                       (get-python-version python)
                                       "/site-packages"))
         (easy-install-pth (string-append site-packages "/easy-install.pth"))
         (new-pth (string-append site-packages "/" name ".pth")))
    (when (file-exists? easy-install-pth)
      (rename-file easy-install-pth new-pth))
    #t))

(define* (ensure-no-mtimes-pre-1980 #:rest _)
  "Ensure that there are no mtimes before 1980-01-02 in the source tree."
  ;; Rationale: patch-and-repack creates tarballs with timestamps at the POSIX
  ;; epoch, 1970-01-01 UTC.  This causes problems with Python packages,
  ;; because Python eggs are ZIP files, and the ZIP format does not support
  ;; timestamps before 1980.
  (let ((early-1980 315619200))  ; 1980-01-02 UTC
    (ftw "." (lambda (file stat flag)
               (unless (<= early-1980 (stat:mtime stat))
                 (utime file early-1980 early-1980))
               #t))
    #t))

(define* (enable-bytecode-determinism #:rest _)
  "Improve determinism of pyc files."
  ;; Set DETERMINISTIC_BUILD to override the embedded mtime in pyc files.
  (setenv "DETERMINISTIC_BUILD" "1")
  ;; Use deterministic hashes for strings, bytes, and datetime objects.
  (setenv "PYTHONHASHSEED" "0")
  #t)

(define %standard-phases
  ;; 'configure' phase is not needed.
  (modify-phases gnu:%standard-phases
    (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980)
    (add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism
      enable-bytecode-determinism)
    (delete 'bootstrap)
    (delete 'configure)
    (replace 'install install)
    (replace 'check check)
    (replace 'build build)
    (add-after 'install 'wrap wrap)
    (add-before 'strip 'rename-pth-file rename-pth-file)))

(define* (python-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
  "Build the given Python package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; python-build-system.scm ends here