guix/scripts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017 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-19)
  31   #:use-module (srfi srfi-37)
  32   #:use-module (ice-9 match)
  33   #:export (args-fold*
  34             parse-command-line
  35             maybe-build
  36             build-package
  37             build-package-source
  38             %distro-age-warning
  39             warn-about-old-distro))
  40
  41 ;;; Commentary:
  42 ;;;
  43 ;;; General code for Guix scripts.
  44 ;;;
  45 ;;; Code:
  46
  47 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
  48   "A wrapper on top of `args-fold' that does proper user-facing error
  49 reporting."
  50   (catch 'misc-error
  51     (lambda ()
  52       (apply args-fold options unrecognized-option-proc
  53              operand-proc seeds))
  54     (lambda (key proc msg args . rest)
  55       ;; XXX: MSG is not i18n'd.
  56       (leave (G_ "invalid argument: ~a~%")
  57              (apply format #f msg args)))))
  58
  59 (define (environment-build-options)
  60   "Return additional build options passed as environment variables."
  61   (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
  62
  63 (define %default-argument-handler
  64   ;; The default handler for non-option command-line arguments.
  65   (lambda (arg result)
  66     (alist-cons 'argument arg result)))
  67
  68 (define* (parse-command-line args options seeds
  69                              #:key
  70                              (argument-handler %default-argument-handler))
  71   "Parse the command-line arguments ARGS as well as arguments passed via the
  72 'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
  73 SRFI-37 options) and return the result, seeded by SEEDS.
  74 Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
  75
  76 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
  77 parameter of 'args-fold'."
  78   (define (parse-options-from args seeds)
  79     ;; Actual parsing takes place here.
  80     (apply args-fold* args options
  81            (lambda (opt name arg . rest)
  82              (leave (G_ "~A: unrecognized option~%") name))
  83            argument-handler
  84            seeds))
  85
  86   (call-with-values
  87       (lambda ()
  88         (parse-options-from (environment-build-options) seeds))
  89     (lambda seeds
  90       ;; ARGS take precedence over what the environment variable specifies.
  91       (parse-options-from args seeds))))
  92
  93 (define* (maybe-build drvs
  94                       #:key dry-run? use-substitutes?)
  95   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
  96 true."
  97   (with-monad %store-monad
  98     (>>= (show-what-to-build* drvs
  99                               #:dry-run? dry-run?
 100                               #:use-substitutes? use-substitutes?)
 101          (lambda (_)
 102            (if dry-run?
 103                (return #f)
 104                (built-derivations drvs))))))
 105
 106 (define* (build-package package
 107                         #:key dry-run? (use-substitutes? #t)
 108                         #:allow-other-keys
 109                         #:rest build-options)
 110   "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
 111 Show what and how will/would be built."
 112   (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
 113     (apply set-build-options*
 114            #:use-substitutes? use-substitutes?
 115            (strip-keyword-arguments '(#:dry-run?) build-options))
 116     (mlet %store-monad ((derivation (package->derivation
 117                                      package #:graft? (and (not dry-run?)
 118                                                            grafting?))))
 119       (mbegin %store-monad
 120         (maybe-build (list derivation)
 121                      #:use-substitutes? use-substitutes?
 122                      #:dry-run? dry-run?)
 123         (return (show-derivation-outputs derivation))))))
 124
 125 (define* (build-package-source package
 126                                #:key dry-run? (use-substitutes? #t)
 127                                #:allow-other-keys
 128                                #:rest build-options)
 129   "Build PACKAGE source using BUILD-OPTIONS."
 130   (mbegin %store-monad
 131     (apply set-build-options*
 132            #:use-substitutes? use-substitutes?
 133            (strip-keyword-arguments '(#:dry-run?) build-options))
 134     (mlet %store-monad ((derivation (origin->derivation
 135                                      (package-source package))))
 136       (mbegin %store-monad
 137         (maybe-build (list derivation)
 138                      #:use-substitutes? use-substitutes?
 139                      #:dry-run? dry-run?)
 140         (return (show-derivation-outputs derivation))))))
 141
 142 (define %distro-age-warning
 143   ;; The age (in seconds) above which we warn that the distro is too old.
 144   (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
 145                                 string->duration)
 146                     (#f  (* 7 24 3600))
 147                     (age (time-second age)))))
 148
 149 (define* (warn-about-old-distro #:optional (old (%distro-age-warning))
 150                                 #:key (suggested-command
 151                                        "guix package -u"))
 152   "Emit a warning if Guix is older than OLD seconds."
 153   (let-syntax ((false-if-not-found
 154                 (syntax-rules ()
 155                   ((_ exp)
 156                    (catch 'system-error
 157                      (lambda ()
 158                        exp)
 159                      (lambda args
 160                        (if (= ENOENT (system-error-errno args))
 161                            #f
 162                            (apply throw args))))))))
 163     (define (seconds->days seconds)
 164       (round (/ seconds (* 3600 24))))
 165
 166     (define age
 167       (match (false-if-not-found
 168               (lstat (string-append (config-directory #:ensure? #f)
 169                                     "/latest")))
 170         (#f    #f)
 171         (stat  (- (time-second (current-time time-utc))
 172                   (stat:mtime stat)))))
 173
 174     (when (and age (>= age old))
 175       (warning (N_ "Your Guix installation is ~a day old.\n"
 176                    "Your Guix installation is ~a days old.\n"
 177                    (seconds->days age))
 178                (seconds->days age)))
 179     (when (or (not age) (>= age old))
 180       (warning (G_ "Consider running 'guix pull' followed by
 181 '~a' to get up-to-date packages and security updates.\n")
 182                suggested-command)
 183       (newline (guix-warning-port)))))
 184
 185 ;;; scripts.scm ends here