guix-devel/guix-build.in

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

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 (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #: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 source?)
  "Eval EXP and return the corresponding derivation path.  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))
        (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.
  '())

(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 (_ "
  -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 (_ "
  -c, --cores=N          allow the use of up to N CPU cores for the build"))
  (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 '(#\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)))))


;;;
;;; 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))

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

  (let* ((opts (parse-options))
         (src? (assoc-ref opts 'source?))
         (drv  (filter-map (match-lambda
                             (('expression . exp)
                              (derivations-from-package-expressions exp 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)))
                                (_
                                 (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))

    (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))))))