guix-play/guix-build.in

#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code

prefix="@prefix@"
datarootdir="@datarootdir@"

GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH

main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
         -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guix.
;;;
;;; 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.
;;;
;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix-build)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:autoload   (distro) (find-packages-by-name)
  #:export (guix-build))

(define _ (cut gettext <> "guix"))
(define N_ (cut ngettext <> <> <> "guix"))

(define %store
  (open-connection))

(define (derivations-from-package-expressions exp system source?)
  "Eval EXP and return the corresponding derivation path for SYSTEM.
When SOURCE? is true, return the derivations of the package sources."
  (let ((p (eval exp (current-module))))
    (if (package? p)
        (if source?
            (package-source-derivation %store (package-source p))
            (package-derivation %store p system))
        (begin
          (format (current-error-port)
                  (_ "expression `~s' does not evaluate to a package")
                  exp)
          (exit 1)))))

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

(define %default-options
  ;; Alist of default option values.
  `((system . ,(%current-system))
    (substitutes? . #t)))

(define-syntax-rule (leave fmt args ...)
  "Format FMT and ARGS to the error port and exit."
  (begin
    (format (current-error-port) fmt args ...)
    (exit 1)))

(define (show-version)
  (display "guix-build (@PACKAGE_NAME@) @PACKAGE_VERSION@\n"))

(define (show-help)
  (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  (display (_ "
  -e, --expression=EXPR  build the package EXPR evaluates to"))
  (display (_ "
  -S, --source           build the packages' source derivations"))
  (display (_ "
  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  (display (_ "
  -d, --derivations      return the derivation paths of the given packages"))
  (display (_ "
  -K, --keep-failed      keep build tree of failed builds"))
  (display (_ "
  -n, --dry-run          do not build the derivations"))
  (display (_ "
      --no-substitutes   build instead of resorting to pre-built substitutes"))
  (display (_ "
  -c, --cores=N          allow the use of up to N CPU cores for the build"))
  (display (_ "
  -r, --root=FILE        make FILE a symlink to the result, and register it
                         as a garbage collector root"))
  (newline)
  (display (_ "
  -h, --help             display this help and exit"))
  (display (_ "
  -V, --version          display version information and exit"))
  (newline)
  (format #t (_ "
Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version)
                  (exit 0)))

        (option '(#\S "source") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'source? #t result)))
        (option '(#\s "system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'system arg
                              (alist-delete 'system 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
                              (call-with-input-string arg read)
                              result)))
        (option '(#\K "keep-failed") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'keep-failed? #t result)))
        (option '(#\c "cores") #t #f
                (lambda (opt name arg result)
                  (let ((c (false-if-exception (string->number arg))))
                    (if c
                        (alist-cons 'cores c result)
                        (leave (_ "~a: not a number~%") arg)))))
        (option '(#\n "dry-run") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'dry-run? #t result)))
        (option '("no-substitutes") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'substitutes? #f
                              (alist-delete 'substitutes? result))))
        (option '(#\r "root") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'gc-root arg result)))))

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

(define (guix-build . args)
  (define (parse-options)
    ;; Return the alist of option values.
    (args-fold args %options
               (lambda (opt name arg result)
                 (leave (_ "~A: unrecognized option~%") name))
               (lambda (arg result)
                 (alist-cons 'argument arg result))
               %default-options))

  (define (register-root drv root)
    ;; Register ROOT as an indirect GC root for DRV's outputs.
    (let* ((root     (string-append (canonicalize-path (dirname root))
                                    "/" root))
           (drv*     (call-with-input-file drv read-derivation))
           (outputs  (derivation-outputs drv*))
           (outputs* (map (compose derivation-output-path cdr) outputs)))
     (catch 'system-error
       (lambda ()
         (match outputs*
           ((output)
            (symlink output root)
            (add-indirect-root %store root))
           ((outputs ...)
            (fold (lambda (output count)
                    (let ((root (string-append root "-" (number->string count))))
                      (symlink output root)
                      (add-indirect-root %store root))
                    (+ 1 count))
                  0
                  outputs))))
       (lambda args
         (format (current-error-port)
                 (_ "failed to create GC root `~a': ~a~%")
                 root (strerror (system-error-errno args)))
         (exit 1)))))

  (setlocale LC_ALL "")
  (textdomain "guix")
  (setvbuf (current-output-port) _IOLBF)
  (setvbuf (current-error-port) _IOLBF)

  (guard (c ((package-input-error? c)
             (let* ((package  (package-error-package c))
                    (input    (package-error-invalid-input c))
                    (location (package-location package))
                    (file     (location-file location))
                    (line     (location-line location))
                    (column   (location-column location)))
               (leave (_ "~a:~a:~a: error: package `~a' has an invalid input: ~s~%")
                      file line column
                      (package-full-name package) input))))
    (let* ((opts (parse-options))
           (src? (assoc-ref opts 'source?))
           (sys  (assoc-ref opts 'system))
           (drv  (filter-map (match-lambda
                              (('expression . exp)
                               (derivations-from-package-expressions exp sys
                                                                     src?))
                              (('argument . (? derivation-path? drv))
                               drv)
                              (('argument . (? string? x))
                               (match (find-packages-by-name x)
                                 ((p _ ...)
                                  (if src?
                                      (let ((s (package-source p)))
                                        (package-source-derivation %store s))
                                      (package-derivation %store p sys)))
                                 (_
                                  (leave (_ "~A: unknown package~%") x))))
                              (_ #f))
                             opts))
           (req  (append-map (lambda (drv-path)
                               (let ((d (call-with-input-file drv-path
                                          read-derivation)))
                                 (derivation-prerequisites-to-build %store d)))
                             drv))
           (req* (delete-duplicates
                  (append (remove (compose (cut valid-path? %store <>)
                                           derivation-path->output-path)
                                  drv)
                          (map derivation-input-path req)))))
      (if (assoc-ref opts 'dry-run?)
          (format (current-error-port)
                  (N_ "~:[the following derivation would be built:~%~{   ~a~%~}~;~]"
                      "~:[the following derivations would be built:~%~{    ~a~%~}~;~]"
                      (length req*))
                  (null? req*) req*)
          (format (current-error-port)
                  (N_ "~:[the following derivation will be built:~%~{   ~a~%~}~;~]"
                      "~:[the following derivations will be built:~%~{    ~a~%~}~;~]"
                      (length req*))
                  (null? req*) req*))

      ;; TODO: Add more options.
      (set-build-options %store
                         #:keep-failed? (assoc-ref opts 'keep-failed?)
                         #:build-cores (or (assoc-ref opts 'cores) 0)
                         #:use-substitutes? (assoc-ref opts 'substitutes?))

      (if (assoc-ref opts 'derivations-only?)
          (format #t "~{~a~%~}" drv)
          (or (assoc-ref opts 'dry-run?)
              (and (build-derivations %store drv)
                   (for-each (lambda (d)
                               (let ((drv (call-with-input-file d
                                            read-derivation)))
                                 (format #t "~{~a~%~}"
                                         (map (match-lambda
                                               ((out-name . out)
                                                (derivation-path->output-path
                                                 d out-name)))
                                              (derivation-outputs drv)))))
                             drv)
                   (let ((roots (filter-map (match-lambda
                                             (('gc-root . root)
                                              root)
                                             (_ #f))
                                            opts)))
                     (when roots
                       (for-each (cut register-root <> <>)
                                 drv roots)
                       #t))))))))

;; Local Variables:
;; eval: (put 'guard 'scheme-indent-function 1)
;; End: