guix/scripts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
   4 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix scripts)
  22   #:use-module (guix grafts)
  23   #:use-module (guix utils)
  24   #:use-module (guix ui)
  25   #:use-module (guix store)
  26   #:use-module (guix monads)
  27   #:use-module (guix packages)
  28   #:use-module (guix derivations)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-37)
  31   #:use-module (ice-9 match)
  32   #:export (args-fold*
  33             parse-command-line
  34             maybe-build
  35             build-package
  36             build-package-source))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; General code for Guix scripts.
  41 ;;;
  42 ;;; Code:
  43
  44 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
  45   "A wrapper on top of `args-fold' that does proper user-facing error
  46 reporting."
  47   (catch 'misc-error
  48     (lambda ()
  49       (apply args-fold options unrecognized-option-proc
  50              operand-proc seeds))
  51     (lambda (key proc msg args . rest)
  52       ;; XXX: MSG is not i18n'd.
  53       (leave (_ "invalid argument: ~a~%")
  54              (apply format #f msg args)))))
  55
  56 (define (environment-build-options)
  57   "Return additional build options passed as environment variables."
  58   (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
  59
  60 (define %default-argument-handler
  61   ;; The default handler for non-option command-line arguments.
  62   (lambda (arg result)
  63     (alist-cons 'argument arg result)))
  64
  65 (define* (parse-command-line args options seeds
  66                              #:key
  67                              (argument-handler %default-argument-handler))
  68   "Parse the command-line arguments ARGS as well as arguments passed via the
  69 'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
  70 SRFI-37 options) and return the result, seeded by SEEDS.
  71 Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
  72
  73 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
  74 parameter of 'args-fold'."
  75   (define (parse-options-from args seeds)
  76     ;; Actual parsing takes place here.
  77     (apply args-fold* args options
  78            (lambda (opt name arg . rest)
  79              (leave (_ "~A: unrecognized option~%") name))
  80            argument-handler
  81            seeds))
  82
  83   (call-with-values
  84       (lambda ()
  85         (parse-options-from (environment-build-options) seeds))
  86     (lambda seeds
  87       ;; ARGS take precedence over what the environment variable specifies.
  88       (parse-options-from args seeds))))
  89
  90 (define* (maybe-build drvs
  91                       #:key dry-run? use-substitutes?)
  92   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
  93 true."
  94   (with-monad %store-monad
  95     (>>= (show-what-to-build* drvs
  96                               #:dry-run? dry-run?
  97                               #:use-substitutes? use-substitutes?)
  98          (lambda (_)
  99            (if dry-run?
 100                (return #f)
 101                (built-derivations drvs))))))
 102
 103 (define* (build-package package
 104                         #:key dry-run? (use-substitutes? #t)
 105                         #:allow-other-keys
 106                         #:rest build-options)
 107   "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
 108 Show what and how will/would be built."
 109   (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
 110     (apply set-build-options*
 111            #:use-substitutes? use-substitutes?
 112            (strip-keyword-arguments '(#:dry-run?) build-options))
 113     (mlet %store-monad ((derivation (package->derivation
 114                                      package #:graft? (and (not dry-run?)
 115                                                            grafting?))))
 116       (mbegin %store-monad
 117         (maybe-build (list derivation)
 118                      #:use-substitutes? use-substitutes?
 119                      #:dry-run? dry-run?)
 120         (return (show-derivation-outputs derivation))))))
 121
 122 (define* (build-package-source package
 123                                #:key dry-run? (use-substitutes? #t)
 124                                #:allow-other-keys
 125                                #:rest build-options)
 126   "Build PACKAGE source using BUILD-OPTIONS."
 127   (mbegin %store-monad
 128     (apply set-build-options*
 129            #:use-substitutes? use-substitutes?
 130            (strip-keyword-arguments '(#:dry-run?) build-options))
 131     (mlet %store-monad ((derivation (origin->derivation
 132                                      (package-source package))))
 133       (mbegin %store-monad
 134         (maybe-build (list derivation)
 135                      #:use-substitutes? use-substitutes?
 136                      #:dry-run? dry-run?)
 137         (return (show-derivation-outputs derivation))))))
 138
 139 ;;; scripts.scm ends here