guix-kreyren/guix/scripts/build.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 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 scripts build)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix import json)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix memoization)
  #:use-module (guix grafts)

  #:use-module (guix utils)

  ;; Use the procedure that destructures "NAME-VERSION" forms.
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-package-name->name+version)))

  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:use-module (guix diagnostics)
  #:autoload   (guix http-client) (http-fetch http-get-error?)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:use-module (gnu packages)
  #:autoload   (guix download) (download-to-store)
  #:autoload   (guix git-download) (git-reference? git-reference-url)
  #:autoload   (guix git) (git-checkout git-checkout? git-checkout-url)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module ((guix progress) #:select (current-terminal-columns))
  #:use-module ((guix build syscalls) #:select (terminal-columns))
  #:export (%standard-build-options
            set-build-options-from-command-line
            set-build-options-from-command-line*
            show-build-options-help

            %transformation-options
            options->transformation
            manifest-entry-with-transformations

            guix-build
            register-root
            register-root*))

(define %default-log-urls
  ;; Default base URLs for build logs.
  '("http://ci.guix.gnu.org/log"))

;; XXX: The following procedure cannot be in (guix store) because of the
;; dependency on (guix derivations).
(define* (log-url store file #:key (base-urls %default-log-urls))
  "Return a URL under one of the BASE-URLS where a build log for FILE can be
found.  Return #f if no build log was found."
  (define (valid-url? url)
    ;; Probe URL and return #t if it is accessible.
    (catch #t
      (lambda ()
        (guard (c ((http-get-error? c) #f))
          (close-port (http-fetch url #:buffered? #f))
          #t))
      (match-lambda*
        (('getaddrinfo-error . _)
         #f)
        (('tls-certificate-error args ...)
         (report-error (G_ "cannot access build log at '~a':~%") url)
         (print-exception (current-error-port) #f
                          'tls-certificate-error args)
         (exit 1))
        ((key . args)
         (apply throw key args)))))

  (define (find-url file)
    (let ((base (basename file)))
      (any (lambda (base-url)
             (let ((url (string-append base-url "/" base)))
               (and (valid-url? url) url)))
           base-urls)))

  (cond ((derivation-path? file)
         (catch 'system-error
           (lambda ()
             ;; Usually we'll have more luck with the output file name since
             ;; the deriver that was used by the server could be different, so
             ;; try one of the output file names.
             (let ((drv (read-derivation-from-file file)))
               (or (find-url (derivation->output-path drv))
                   (find-url file))))
           (lambda args
             ;; As a last resort, try the .drv.
             (if (= ENOENT (system-error-errno args))
                 (find-url file)
                 (apply throw args)))))
        (else
         (find-url file))))

(define (register-root store paths root)
  "Register ROOT as an indirect GC root for all of PATHS."
  (let* ((root (if (string-prefix? "/" root)
                   root
                   (string-append (canonicalize-path (dirname root))
                                  "/" (basename root)))))
    (catch 'system-error
      (lambda ()
        (match paths
          ((path)
           (symlink path root)
           (add-indirect-root store root))
          ((paths ...)
           (fold (lambda (path count)
                   (let ((root (string-append root
                                              "-"
                                              (number->string count))))
                     (symlink path root)
                     (add-indirect-root store root))
                   (+ 1 count))
                 0
                 paths))))
      (lambda args
        (leave (G_ "failed to create GC root `~a': ~a~%")
               root (strerror (system-error-errno args)))))))

(define register-root*
  (store-lift register-root))

(define (numeric-extension? file-name)
  "Return true if FILE-NAME ends with digits."
  (string-every char-set:hex-digit (file-extension file-name)))

(define (tarball-base-name file-name)
  "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
extensions."
  ;; TODO: Factorize.
  (cond ((not (file-extension file-name))
         file-name)
        ((numeric-extension? file-name)
         file-name)
        ((string=? (file-extension file-name) "tar")
         (file-sans-extension file-name))
        ((file-extension file-name)
         =>
         (match-lambda
           ("scm" file-name)
           (else  (tarball-base-name (file-sans-extension file-name)))))
        (else
         file-name)))


;; Files to be downloaded.
(define-record-type <downloaded-file>
  (downloaded-file uri recursive?)
  downloaded-file?
  (uri        downloaded-file-uri)
  (recursive? downloaded-file-recursive?))

(define download-to-store*
  (store-lift download-to-store))

(define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
                                               system target)
  "Download FILE and return the result as a store item."
  (match file
    (($ <downloaded-file> uri recursive?)
     (download-to-store* uri #:recursive? recursive?))))

(define* (package-with-source p uri #:optional version)
  "Return a package based on P but with its source taken from URI.  Extract
the new package's version number from URI."
  (let ((base (tarball-base-name (basename uri))))
    (let-values (((_ version*)
                  (hyphen-package-name->name+version base)))
      (package (inherit p)
               (version (or version version*
                            (package-version p)))

               ;; Use #:recursive? #t to allow for directories.
               (source (downloaded-file uri #t))))))


;;;
;;; Transformations.
;;;

(define (transform-package-source sources)
  "Return a transformation procedure that replaces package sources with the
matching URIs given in SOURCES."
  (define new-sources
    (map (lambda (uri)
           (match (string-index uri #\=)
             (#f
              ;; Determine the package name and version from URI.
              (call-with-values
                  (lambda ()
                    (hyphen-package-name->name+version
                     (tarball-base-name (basename uri))))
                (lambda (name version)
                  (list name version uri))))
             (index
              ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
              (call-with-values
                  (lambda ()
                    (package-name->name+version (string-take uri index)))
                (lambda (name version)
                  (list name version
                        (string-drop uri (+ 1 index))))))))
         sources))

  (lambda (store obj)
    (let loop ((sources  new-sources)
               (result   '()))
      (match obj
        ((? package? p)
         (match (assoc-ref sources (package-name p))
           ((version source)
            (package-with-source p source version))
           (#f
            p)))
        (_
         obj)))))

(define (evaluate-replacement-specs specs proc)
  "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
PROC is called with the package to be replaced and its replacement according
to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
package it refers to could not be found."
  (define not-equal
    (char-set-complement (char-set #\=)))

  (map (lambda (spec)
         (match (string-tokenize spec not-equal)
           ((spec new)
            (cons spec
                  (let ((new (specification->package new)))
                    (lambda (old)
                      (proc old new)))))
           (x
            (leave (G_ "invalid replacement specification: ~s~%") spec))))
       specs))

(define (transform-package-inputs replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"guile=guile@2.1\" meaning that, any dependency on a package
called \"guile\" must be replaced with a dependency on a version 2.1 of
\"guile\"."
  (let* ((replacements (evaluate-replacement-specs replacement-specs
                                                   (lambda (old new)
                                                     new)))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define (transform-package-inputs/graft replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
current 'gnutls' package, after which version 3.5.4 is grafted onto them."
  (define (set-replacement old new)
    (package (inherit old) (replacement new)))

  (let* ((replacements (evaluate-replacement-specs replacement-specs
                                                   set-replacement))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define %not-equal
  (char-set-complement (char-set #\=)))

(define (package-git-url package)
  "Return the URL of the Git repository for package, or raise an error if
the source of PACKAGE is not fetched from a Git repository."
  (let ((source (package-source package)))
    (cond ((and (origin? source)
                (git-reference? (origin-uri source)))
           (git-reference-url (origin-uri source)))
          ((git-checkout? source)
           (git-checkout-url source))
          (else
           (leave (G_ "the source of ~a is not a Git reference~%")
                  (package-full-name package))))))

(define (evaluate-git-replacement-specs specs proc)
  "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
replacement package.  Raise an error if an element of SPECS uses invalid
syntax, or if a package it refers to could not be found."
  (map (lambda (spec)
         (match (string-tokenize spec %not-equal)
           ((spec branch-or-commit)
            (define (replace old)
              (let* ((source (package-source old))
                     (url    (package-git-url old)))
                (proc old url branch-or-commit)))

            (cons spec replace))
           (x
            (leave (G_ "invalid replacement specification: ~s~%") spec))))
       specs))

(define (transform-package-source-branch replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"guile-next=stable-3.0\" meaning that packages are built using
'guile-next' from the latest commit on its 'stable-3.0' branch."
  (define (replace old url branch)
    (package
      (inherit old)
      (version (string-append "git." (string-map (match-lambda
                                                   (#\/ #\-)
                                                   (chr chr))
                                                 branch)))
      (source (git-checkout (url url) (branch branch)
                            (recursive? #t)))))

  (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                       replace))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define (transform-package-source-commit replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"guile-next=cabba9e\" meaning that packages are built using
'guile-next' from commit 'cabba9e'."
  (define (replace old url commit)
    (package
      (inherit old)
      (version (if (and (> (string-length commit) 1)
                        (string-prefix? "v" commit)
                        (char-set-contains? char-set:digit
                                            (string-ref commit 1)))
                   (string-drop commit 1)        ;looks like a tag like "v1.0"
                   (string-append "git."
                                  (if (< (string-length commit) 7)
                                      commit
                                      (string-take commit 7)))))
      (source (git-checkout (url url) (commit commit)
                            (recursive? #t)))))

  (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                       replace))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define (transform-package-source-git-url replacement-specs)
  "Return a procedure that, when passed a package, replaces its dependencies
according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
\"guile-json=https://gitthing.com/…\" meaning that packages are built using
a checkout of the Git repository at the given URL."
  (define replacements
    (map (lambda (spec)
           (match (string-tokenize spec %not-equal)
             ((spec url)
              (cons spec
                    (lambda (old)
                      (package
                        (inherit old)
                        (source (git-checkout (url url)
                                              (recursive? #t)))))))
             (_
              (leave (G_ "~a: invalid Git URL replacement specification~%")
                     spec))))
         replacement-specs))

  (define rewrite
    (package-input-rewriting/spec replacements))

  (lambda (store obj)
    (if (package? obj)
        (rewrite obj)
        obj)))

(define (package-dependents/spec top bottom)
  "Return the list of dependents of BOTTOM, a spec string, that are also
dependencies of TOP, a package."
  (define-values (name version)
    (package-name->name+version bottom))

  (define dependent?
    (mlambda (p)
      (and (package? p)
           (or (and (string=? name (package-name p))
                    (or (not version)
                        (version-prefix? version (package-version p))))
               (match (bag-direct-inputs (package->bag p))
                 (((labels dependencies . _) ...)
                  (any dependent? dependencies)))))))

  (filter dependent? (package-closure (list top))))

(define (package-toolchain-rewriting p bottom toolchain)
  "Return a procedure that, when passed a package that's either BOTTOM or one
of its dependents up to P so, changes it so it is built with TOOLCHAIN.
TOOLCHAIN must be an input list."
  (define rewriting-property
    (gensym " package-toolchain-rewriting"))

  (match (package-dependents/spec p bottom)
    (()                                           ;P does not depend on BOTTOM
     identity)
    (set
     ;; SET is the list of packages "between" P and BOTTOM (included) whose
     ;; toolchain needs to be changed.
     (package-mapping (lambda (p)
                        (if (or (assq rewriting-property
                                      (package-properties p))
                                (not (memq p set)))
                            p
                            (let ((p (package-with-c-toolchain p toolchain)))
                              (package/inherit p
                                (properties `((,rewriting-property . #t)
                                              ,@(package-properties p)))))))
                      (lambda (p)
                        (or (assq rewriting-property (package-properties p))
                            (not (memq p set))))
                      #:deep? #t))))

(define (transform-package-toolchain replacement-specs)
  "Return a procedure that, when passed a package, changes its toolchain or
that of its dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is
a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
the left of the equal sign must be built with the toolchain to the right of
the equal sign."
  (define split-on-commas
    (cute string-tokenize <> (char-set-complement (char-set #\,))))

  (define (specification->input spec)
    (let ((package (specification->package spec)))
      (list (package-name package) package)))

  (define replacements
    (map (lambda (spec)
           (match (string-tokenize spec %not-equal)
             ((spec (= split-on-commas toolchain))
              (cons spec (map specification->input toolchain)))
             (_
              (leave (G_ "~a: invalid toolchain replacement specification~%")
                     spec))))
         replacement-specs))

  (lambda (store obj)
    (if (package? obj)
        (or (any (match-lambda
                   ((bottom . toolchain)
                    ((package-toolchain-rewriting obj bottom toolchain) obj)))
                 replacements)
            obj)
        obj)))

(define (transform-package-with-debug-info specs)
  "Return a procedure that, when passed a package, set its 'replacement' field
to the same package but with #:strip-binaries? #f in its 'arguments' field."
  (define (non-stripped p)
    (package
      (inherit p)
      (arguments
       (substitute-keyword-arguments (package-arguments p)
         ((#:strip-binaries? _ #f) #f)))))

  (define (package-with-debug-info p)
    (if (member "debug" (package-outputs p))
        p
        (let loop ((p p))
          (match (package-replacement p)
            (#f
             (package
               (inherit p)
               (replacement (non-stripped p))))
            (next
             (package
               (inherit p)
               (replacement (loop next))))))))

  (define rewrite
    (package-input-rewriting/spec (map (lambda (spec)
                                         (cons spec package-with-debug-info))
                                       specs)))

  (lambda (store obj)
    (if (package? obj)
        (rewrite obj)
        obj)))

(define (transform-package-tests specs)
  "Return a procedure that, when passed a package, sets #:tests? #f in its
'arguments' field."
  (define (package-without-tests p)
    (package/inherit p
      (arguments
       (substitute-keyword-arguments (package-arguments p)
         ((#:tests? _ #f) #f)))))

  (define rewrite
    (package-input-rewriting/spec (map (lambda (spec)
                                         (cons spec package-without-tests))
                                       specs)))

  (lambda (store obj)
    (if (package? obj)
        (rewrite obj)
        obj)))

(define %transformations
  ;; Transformations that can be applied to things to build.  The car is the
  ;; key used in the option alist, and the cdr is the transformation
  ;; procedure; it is called with two arguments: the store, and a list of
  ;; things to build.
  `((with-source . ,transform-package-source)
    (with-input  . ,transform-package-inputs)
    (with-graft  . ,transform-package-inputs/graft)
    (with-branch . ,transform-package-source-branch)
    (with-commit . ,transform-package-source-commit)
    (with-git-url . ,transform-package-source-git-url)
    (with-c-toolchain . ,transform-package-toolchain)
    (with-debug-info . ,transform-package-with-debug-info)
    (without-tests . ,transform-package-tests)))

(define (transformation-procedure key)
  "Return the transformation procedure associated with KEY, a symbol such as
'with-source', or #f if there is none."
  (any (match-lambda
         ((k . proc)
          (and (eq? k key) proc)))
       %transformations))

(define %transformation-options
  ;; The command-line interface to the above transformations.
  (let ((parser (lambda (symbol)
                  (lambda (opt name arg result . rest)
                    (apply values
                           (alist-cons symbol arg result)
                           rest)))))
    (list (option '("with-source") #t #f
                  (parser 'with-source))
          (option '("with-input") #t #f
                  (parser 'with-input))
          (option '("with-graft") #t #f
                  (parser 'with-graft))
          (option '("with-branch") #t #f
                  (parser 'with-branch))
          (option '("with-commit") #t #f
                  (parser 'with-commit))
          (option '("with-git-url") #t #f
                  (parser 'with-git-url))
          (option '("with-c-toolchain") #t #f
                  (parser 'with-c-toolchain))
          (option '("with-debug-info") #t #f
                  (parser 'with-debug-info))
          (option '("without-tests") #t #f
                  (parser 'without-tests)))))

(define (show-transformation-options-help)
  (display (G_ "
      --with-source=[PACKAGE=]SOURCE
                         use SOURCE when building the corresponding package"))
  (display (G_ "
      --with-input=PACKAGE=REPLACEMENT
                         replace dependency PACKAGE by REPLACEMENT"))
  (display (G_ "
      --with-graft=PACKAGE=REPLACEMENT
                         graft REPLACEMENT on packages that refer to PACKAGE"))
  (display (G_ "
      --with-branch=PACKAGE=BRANCH
                         build PACKAGE from the latest commit of BRANCH"))
  (display (G_ "
      --with-commit=PACKAGE=COMMIT
                         build PACKAGE from COMMIT"))
  (display (G_ "
      --with-git-url=PACKAGE=URL
                         build PACKAGE from the repository at URL"))
  (display (G_ "
      --with-c-toolchain=PACKAGE=TOOLCHAIN
                         build PACKAGE and its dependents with TOOLCHAIN"))
  (display (G_ "
      --with-debug-info=PACKAGE
                         build PACKAGE and preserve its debug info"))
  (display (G_ "
      --without-tests=PACKAGE
                         build PACKAGE without running its tests")))


(define (options->transformation opts)
  "Return a procedure that, when passed an object to build (package,
derivation, etc.), applies the transformations specified by OPTS."
  (define applicable
    ;; List of applicable transformations as symbol/procedure pairs in the
    ;; order in which they appear on the command line.
    (filter-map (match-lambda
                  ((key . value)
                   (match (transformation-procedure key)
                     (#f
                      #f)
                     (transform
                      ;; XXX: We used to pass TRANSFORM a list of several
                      ;; arguments, but we now pass only one, assuming that
                      ;; transform composes well.
                      (list key value (transform (list value)))))))
                (reverse opts)))

  (define (package-with-transformation-properties p)
    (package/inherit p
      (properties `((transformations
                     . ,(map (match-lambda
                               ((key value _)
                                (cons key value)))
                             applicable))
                    ,@(package-properties p)))))

  (lambda (store obj)
    (define (tagged-object new)
      (if (and (not (eq? obj new))
               (package? new) (not (null? applicable)))
          (package-with-transformation-properties new)
          new))

    (tagged-object
     (fold (match-lambda*
             (((name value transform) obj)
              (let ((new (transform store obj)))
                (when (eq? new obj)
                  (warning (G_ "transformation '~a' had no effect on ~a~%")
                           name
                           (if (package? obj)
                               (package-full-name obj)
                               obj)))
                new)))
           obj
           applicable))))

(define (package-transformations package)
  "Return the transformations applied to PACKAGE according to its properties."
  (match (assq-ref (package-properties package) 'transformations)
    (#f '())
    (transformations transformations)))

(define (manifest-entry-with-transformations entry)
  "Return ENTRY with an additional 'transformations' property if it's not
already there."
  (let ((properties (manifest-entry-properties entry)))
    (if (assq 'transformations properties)
        entry
        (let ((item (manifest-entry-item entry)))
          (manifest-entry
            (inherit entry)
            (properties
             (match (and (package? item)
                         (package-transformations item))
               ((or #f '())
                properties)
               (transformations
                `((transformations . ,transformations)
                  ,@properties)))))))))


;;;
;;; Standard command-line build options.
;;;

(define (show-build-options-help)
  "Display on the current output port help about the standard command-line
options handled by 'set-build-options-from-command-line', and listed in
'%standard-build-options'."
  (display (G_ "
  -L, --load-path=DIR    prepend DIR to the package module search path"))
  (display (G_ "
  -K, --keep-failed      keep build tree of failed builds"))
  (display (G_ "
  -k, --keep-going       keep going when some of the derivations fail"))
  (display (G_ "
  -n, --dry-run          do not build the derivations"))
  (display (G_ "
      --fallback         fall back to building when the substituter fails"))
  (display (G_ "
      --no-substitutes   build instead of resorting to pre-built substitutes"))
  (display (G_ "
      --substitute-urls=URLS
                         fetch substitute from URLS if they are authorized"))
  (display (G_ "
      --no-grafts        do not graft packages"))
  (display (G_ "
      --no-offload       do not attempt to offload builds"))
  (display (G_ "
      --max-silent-time=SECONDS
                         mark the build as failed after SECONDS of silence"))
  (display (G_ "
      --timeout=SECONDS  mark the build as failed after SECONDS of activity"))
  (display (G_ "
      --rounds=N         build N times in a row to detect non-determinism"))
  (display (G_ "
  -c, --cores=N          allow the use of up to N CPU cores for the build"))
  (display (G_ "
  -M, --max-jobs=N       allow at most N build jobs"))
  (display (G_ "
      --help-transform   list package transformation options not shown here"))
  (display (G_ "
      --debug=LEVEL      produce debugging output at LEVEL")))

(define (set-build-options-from-command-line store opts)
  "Given OPTS, an alist as returned by 'args-fold' given
'%standard-build-options', set the corresponding build options on STORE."

  ;; '--keep-failed' has no effect when talking to a remote daemon.  Catch the
  ;; case where GUIX_DAEMON_SOCKET=guix://….
  (when (and (assoc-ref opts 'keep-failed?)
             (let* ((socket (store-connection-socket store))
                    (peer   (catch 'system-error
                              (lambda ()
                                (and (file-port? socket)
                                     (getpeername socket)))
                              (const #f))))
               (and peer (not (= AF_UNIX (sockaddr:fam peer))))))
    (warning (G_ "'--keep-failed' ignored since you are \
talking to a remote daemon\n")))

  (set-build-options store
                     #:keep-failed? (assoc-ref opts 'keep-failed?)
                     #:keep-going? (assoc-ref opts 'keep-going?)
                     #:rounds (assoc-ref opts 'rounds)
                     #:build-cores (assoc-ref opts 'cores)
                     #:max-build-jobs (assoc-ref opts 'max-jobs)
                     #:fallback? (assoc-ref opts 'fallback?)
                     #:use-substitutes? (assoc-ref opts 'substitutes?)
                     #:substitute-urls (assoc-ref opts 'substitute-urls)
                     #:offload? (and (assoc-ref opts 'offload?)
                                     (not (assoc-ref opts 'keep-failed?)))
                     #:max-silent-time (assoc-ref opts 'max-silent-time)
                     #:timeout (assoc-ref opts 'timeout)
                     #:print-build-trace (assoc-ref opts 'print-build-trace?)
                     #:print-extended-build-trace?
                     (assoc-ref opts 'print-extended-build-trace?)
                     #:multiplexed-build-output?
                     (assoc-ref opts 'multiplexed-build-output?)
                     #:verbosity (assoc-ref opts 'debug)))

(define set-build-options-from-command-line*
  (store-lift set-build-options-from-command-line))

(define %standard-build-options
  ;; List of standard command-line options for tools that build something.
  (list (option '(#\L "load-path") #t #f
                (lambda (opt name arg result . rest)
                  ;; XXX: Imperatively modify the search paths.
                  (%package-module-path (cons arg (%package-module-path)))
                  (%patch-path (cons arg (%patch-path)))
                  (set! %load-path (cons arg %load-path))
                  (set! %load-compiled-path (cons arg %load-compiled-path))

                  (apply values (cons result rest))))
        (option '(#\K "keep-failed") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'keep-failed? #t result)
                         rest)))
        (option '(#\k "keep-going") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'keep-going? #t result)
                         rest)))
        (option '("rounds") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'rounds (string->number* arg)
                                     result)
                         rest)))
        (option '("fallback") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'fallback? #t
                                     (alist-delete 'fallback? result))
                         rest)))
        (option '("no-substitutes") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitutes? #f
                                     (alist-delete 'substitutes? result))
                         rest)))
        (option '("substitute-urls") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitute-urls
                                     (string-tokenize arg)
                                     (alist-delete 'substitute-urls result))
                         rest)))
        (option '("no-grafts") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'graft? #f
                                     (alist-delete 'graft? result eq?))
                         rest)))
        (option '("no-offload" "no-build-hook") #f #f
                (lambda (opt name arg result . rest)
                  (when (string=? name "no-build-hook")
                    (warning (G_ "'--no-build-hook' is deprecated; \
use '--no-offload' instead~%")))

                  (apply values
                         (alist-cons 'offload? #f
                                     (alist-delete 'offload? result))
                         rest)))
        (option '("max-silent-time") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'max-silent-time (string->number* arg)
                                     result)
                         rest)))
        (option '("timeout") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'timeout (string->number* arg) result)
                         rest)))
        (option '("debug") #t #f
                (lambda (opt name arg result . rest)
                  (let ((level (string->number* arg)))
                    (apply values
                           (alist-cons 'debug level
                                       (alist-delete 'debug result))
                           rest))))
        (option '(#\c "cores") #t #f
                (lambda (opt name arg result . rest)
                  (let ((c (false-if-exception (string->number arg))))
                    (if c
                        (apply values (alist-cons 'cores c result) rest)
                        (leave (G_ "not a number: '~a' option argument: ~a~%")
                               name arg)))))
        (option '(#\M "max-jobs") #t #f
                (lambda (opt name arg result . rest)
                  (let ((c (false-if-exception (string->number arg))))
                    (if c
                        (apply values (alist-cons 'max-jobs c result) rest)
                        (leave (G_ "not a number: '~a' option argument: ~a~%")
                               name arg)))))
        (option '("help-transform") #f #f
                (lambda _
                  (format #t
                          (G_ "Available package transformation options:~%"))
                  (show-transformation-options-help)
                  (newline)
                  (exit 0)))))


;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((build-mode . ,(build-mode normal))
    (graft? . #t)
    (substitutes? . #t)
    (offload? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (verbosity . 2)
    (debug . 0)))

(define (show-help)
  (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  (display (G_ "
  -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
  (display (G_ "
  -f, --file=FILE        build the package or derivation that the code within
                         FILE evaluates to"))
  (display (G_ "
  -m, --manifest=FILE    build the packages that the manifest given in FILE
                         evaluates to"))
  (display (G_ "
  -S, --source           build the packages' source derivations"))
  (display (G_ "
      --sources[=TYPE]   build source derivations; TYPE may optionally be one
                         of \"package\", \"all\" (default), or \"transitive\""))
  (display (G_ "
  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  (display (G_ "
      --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
  (display (G_ "
  -d, --derivations      return the derivation paths of the given packages"))
  (display (G_ "
      --check            rebuild items to check for non-determinism issues"))
  (display (G_ "
      --repair           repair the specified items"))
  (display (G_ "
  -r, --root=FILE        make FILE a symlink to the result, and register it
                         as a garbage collector root"))
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (display (G_ "
  -q, --quiet            do not show the build log"))
  (display (G_ "
      --log-file         return the log file names for the given derivations"))
  (newline)
  (show-build-options-help)
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specifications of the command-line options.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix build")))
         (option '(#\S "source") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'source #t result)))
         (option '("sources") #f #t
                 (lambda (opt name arg result)
                   (match arg
                     ("package"
                      (alist-cons 'source #t result))
                     ((or "all" #f)
                      (alist-cons 'source package-direct-sources result))
                     ("transitive"
                      (alist-cons 'source package-transitive-sources result))
                     (else
                      (leave (G_ "invalid argument: '~a' option argument: ~a, ~
must be one of 'package', 'all', or 'transitive'~%")
                             name arg)))))
         (option '("check") #f #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'build-mode (build-mode check)
                                      result)
                          rest)))
         (option '("repair") #f #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'build-mode (build-mode repair)
                                      result)
                          rest)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg result)))
         (option '("target") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'target arg
                               (alist-delete 'target result eq?))))
         (option '(#\d "derivations") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'derivations-only? #t result)))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
         (option '(#\f "file") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file arg result)))
         (option '(#\m "manifest") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'manifest arg result)))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
         (option '(#\r "root") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'gc-root arg result)))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '(#\q "quiet") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity 0
                               (alist-delete 'verbosity result))))
         (option '("log-file") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'log-file? #t result)))

         (append %transformation-options
                 %standard-build-options)))

(define (options->things-to-build opts)
  "Read the arguments from OPTS and return a list of high-level objects to
build---packages, gexps, derivations, and so on."
  (define (validate-type x)
    (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
      (raise (make-compound-condition
               (formatted-message (G_ "~s: not something we can build~%") x)
               (condition
                (&fix-hint
                 (hint
                   (if (unspecified? x)
                       (G_ "If you build from a file, make sure the last Scheme
expression returns a package value.  @code{define-public} defines a variable,
but returns @code{#<unspecified>}.  To fix this, add a Scheme expression at
the end of the file that consists only of the package's variable name you
defined, as in this example:

@example
(define-public my-package
  (package
    ...))

my-package
@end example")
                       (G_ "If you build from a file, make sure the last
Scheme expression returns a package, gexp, derivation or a list of such
values.")))))))))

  (define (ensure-list x)
    (let ((lst (match x
                 ((x ...) x)
                 (x       (list x)))))
      (for-each validate-type lst)
      lst))

  (append-map (match-lambda
                (('argument . (? string? spec))
                 (cond ((derivation-path? spec)
                        (catch 'system-error
                          (lambda ()
                            ;; Ask for absolute file names so that .drv file
                            ;; names passed from the user to 'read-derivation'
                            ;; are absolute when it returns.
                            (let ((spec (canonicalize-path spec)))
                              (list (read-derivation-from-file spec))))
                          (lambda args
                            ;; Non-existent .drv files can be substituted down
                            ;; the road, so don't error out.
                            (if (= ENOENT (system-error-errno args))
                                '()
                                (apply throw args)))))
                       ((store-path? spec)
                        ;; Nothing to do; maybe for --log-file.
                        '())
                       (else
                        (list (specification->package spec)))))
                (('file . file)
                 (let ((file (or (and (string-suffix? ".json" file)
                                      (json->scheme-file file))
                                 file)))
                   (ensure-list (load* file (make-user-module '())))))
                (('manifest . manifest)
                 (map manifest-entry-item
                      (manifest-entries
                       (load* manifest
                              (make-user-module '((guix profiles) (gnu)))))))
                (('expression . str)
                 (ensure-list (read/eval str)))
                (('argument . (? derivation? drv))
                 drv)
                (_ '()))
              opts))

(define (options->derivations store opts)
  "Given OPTS, the result of 'args-fold', return a list of derivations to
build."
  (define transform
    (options->transformation opts))

  (define package->derivation
    (match (assoc-ref opts 'target)
      (#f package-derivation)
      (triplet
       (cut package-cross-derivation <> <> triplet <>))))

  (define src    (assoc-ref opts 'source))
  (define graft? (assoc-ref opts 'graft?))
  (define systems
    (match (filter-map (match-lambda
                         (('system . system) system)
                         (_ #f))
                       opts)
      (()      (list (%current-system)))
      (systems systems)))

  (define things-to-build
    (map (cut transform store <>)
         (options->things-to-build opts)))

  (define (compute-derivation obj system)
    ;; Compute the derivation of OBJ for SYSTEM.
    (match obj
      ((? package? p)
       (let ((p (or (and graft? (package-replacement p)) p)))
         (match src
           (#f
            (list (package->derivation store p system)))
           (#t
            (match (package-source p)
              (#f
               (warning (package-location p)
                        (G_ "package '~a' has no source~%")
                        (package-name p))
               '())
              (s
               (list (package-source-derivation store s)))))
           (proc
            (map (cut package-source-derivation store <>)
                 (proc p))))))
      ((? derivation? drv)
       (list drv))
      ((? procedure? proc)
       (list (run-with-store store
               (mbegin %store-monad
                 (set-guile-for-build (default-guile))
                 (proc))
               #:system system)))
      ((? file-like? obj)
       (list (run-with-store store
               (lower-object obj system
                             #:target (assoc-ref opts 'target))
               #:system system)))
      ((? gexp? gexp)
       (list (run-with-store store
               (mbegin %store-monad
                 (set-guile-for-build (default-guile))
                 (gexp->derivation "gexp" gexp
                                   #:system system))
               #:system system)))))

  ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
  ;; of user packages.  Since 'guix build' is the primary tool for people
  ;; testing new packages, report such errors gracefully.
  (with-unbound-variable-handling
   (parameterize ((%graft? graft?))
     (append-map (lambda (system)
                   (concatenate
                    (map/accumulate-builds store
                                           (cut compute-derivation <> system)
                                           things-to-build)))
                 systems))))

(define (show-build-log store file urls)
  "Show the build log for FILE, falling back to remote logs from URLS if
needed."
  (let ((log (or (log-file store file)
                 (log-url store file #:base-urls urls))))
    (if log
        (format #t "~a~%" log)
        (leave (G_ "no build log for '~a'~%") file))))


;;;
;;; Entry point.
;;;

(define-command (guix-build . args)
  (category packaging)
  (synopsis "build packages or derivations without installing them")

  (define opts
    (parse-command-line args %options
                        (list %default-options)))

  (define graft?
    (assoc-ref opts 'graft?))

  (with-error-handling
    (with-status-verbosity (assoc-ref opts 'verbosity)
      (with-store store
        ;; Set the build options before we do anything else.
        (set-build-options-from-command-line store opts)

        (with-build-handler (build-notifier #:use-substitutes?
                                            (assoc-ref opts 'substitutes?)
                                            #:verbosity
                                            (assoc-ref opts 'verbosity)
                                            #:dry-run?
                                            (assoc-ref opts 'dry-run?))
          (parameterize ((current-terminal-columns (terminal-columns))

                         ;; Set grafting upfront in case the user's input
                         ;; depends on it (e.g., a manifest or code snippet that
                         ;; calls 'gexp->derivation').
                         (%graft?                  graft?))
            (let* ((mode  (assoc-ref opts 'build-mode))
                   (drv   (options->derivations store opts))
                   (urls  (map (cut string-append <> "/log")
                               (if (assoc-ref opts 'substitutes?)
                                   (or (assoc-ref opts 'substitute-urls)
                                       ;; XXX: This does not necessarily match the
                                       ;; daemon's substitute URLs.
                                       %default-substitute-urls)
                                   '())))
                   (items (filter-map (match-lambda
                                        (('argument . (? store-path? file))
                                         ;; If FILE is a .drv that's not in
                                         ;; store, keep it so that it can be
                                         ;; substituted.
                                         (and (or (not (derivation-path? file))
                                                  (not (file-exists? file)))
                                              file))
                                        (_ #f))
                                      opts))
                   (roots (filter-map (match-lambda
                                        (('gc-root . root) root)
                                        (_ #f))
                                      opts)))

              (cond ((assoc-ref opts 'log-file?)
                     ;; Pass 'show-build-log' the output file names, not the
                     ;; derivation file names, because there can be several
                     ;; derivations leading to the same output.
                     (for-each (cut show-build-log store <> urls)
                               (delete-duplicates
                                (append (map derivation->output-path drv)
                                        items))))
                    ((assoc-ref opts 'derivations-only?)
                     (format #t "~{~a~%~}" (map derivation-file-name drv))
                     (for-each (cut register-root store <> <>)
                               (map (compose list derivation-file-name) drv)
                               roots))
                    (else
                     (and (build-derivations store (append drv items)
                                             mode)
                          (for-each show-derivation-outputs drv)
                          (for-each (cut register-root store <> <>)
                                    (map (lambda (drv)
                                           (map cdr
                                                (derivation->output-paths drv)))
                                         drv)
                                    roots)))))))))))