[jackhill/guix/guix.git] / guix / scripts.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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)
  #:use-module (guix grafts)
  #:use-module (guix utils)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module ((guix profiles) #:select (%profile-directory))
  #:autoload   (guix describe) (current-profile-date)
  #:use-module (guix build syscalls)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:export (args-fold*
            parse-command-line
            maybe-build
            build-package
            build-package-source
            %distro-age-warning
            warn-about-old-distro
            %disk-space-warning
            warn-about-disk-space))

;;; Commentary:
;;;
;;; General code for Guix scripts.
;;;
;;; Code:

(define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
  "A wrapper on top of `args-fold' that does proper user-facing error
reporting."
  (catch 'misc-error
    (lambda ()
      (apply args-fold args options unrecognized-option-proc
             operand-proc seeds))
    (lambda (key proc msg args . rest)
      ;; XXX: MSG is not i18n'd.
      (leave (G_ "invalid argument: ~a~%")
             (apply format #f msg args)))))

(define (environment-build-options)
  "Return additional build options passed as environment variables."
  (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))

(define %default-argument-handler
  ;; The default handler for non-option command-line arguments.
  (lambda (arg result)
    (alist-cons 'argument arg result)))

(define* (parse-command-line args options seeds
                             #:key
                             (build-options? #t)
                             (argument-handler %default-argument-handler))
  "Parse the command-line arguments ARGS according to OPTIONS (a list of
SRFI-37 options) and return the result, seeded by SEEDS.  When BUILD-OPTIONS?
is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
variable.  Command-line options take precedence those passed via
'GUIX_BUILD_OPTIONS'.

ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
parameter of 'args-fold'."
  (define (parse-options-from args seeds)
    ;; Actual parsing takes place here.
    (apply args-fold* args options
           (lambda (opt name arg . rest)
             (leave (G_ "~A: unrecognized option~%") name))
           argument-handler
           seeds))

  (call-with-values
      (lambda ()
        (if build-options?
            (parse-options-from (environment-build-options) seeds)
            (apply values seeds)))
    (lambda seeds
      ;; ARGS take precedence over what the environment variable specifies.
      (parse-options-from args seeds))))

(define* (maybe-build drvs
                      #:key dry-run? use-substitutes?)
  "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
true."
  (with-monad %store-monad
    (>>= (show-what-to-build* drvs
                              #:dry-run? dry-run?
                              #:use-substitutes? use-substitutes?)
         (lambda (_)
           (if dry-run?
               (return #f)
               (built-derivations drvs))))))

(define* (build-package package
                        #:key dry-run? (use-substitutes? #t)
                        #:allow-other-keys
                        #:rest build-options)
  "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
Show what and how will/would be built."
  (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
    (apply set-build-options*
           #:use-substitutes? use-substitutes?
           (strip-keyword-arguments '(#:dry-run?) build-options))
    (mlet %store-monad ((derivation (package->derivation
                                     package #:graft? (and (not dry-run?)
                                                           grafting?))))
      (mbegin %store-monad
        (maybe-build (list derivation)
                     #:use-substitutes? use-substitutes?
                     #:dry-run? dry-run?)
        (return (show-derivation-outputs derivation))))))

(define* (build-package-source package
                               #:key dry-run? (use-substitutes? #t)
                               #:allow-other-keys
                               #:rest build-options)
  "Build PACKAGE source using BUILD-OPTIONS."
  (mbegin %store-monad
    (apply set-build-options*
           #:use-substitutes? use-substitutes?
           (strip-keyword-arguments '(#:dry-run?) build-options))
    (mlet %store-monad ((derivation (origin->derivation
                                     (package-source package))))
      (mbegin %store-monad
        (maybe-build (list derivation)
                     #:use-substitutes? use-substitutes?
                     #:dry-run? dry-run?)
        (return (show-derivation-outputs derivation))))))

(define %distro-age-warning
  ;; The age (in seconds) above which we warn that the distro is too old.
  (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
                                string->duration)
                    (#f  (* 7 24 3600))
                    (age (time-second age)))))

(define* (warn-about-old-distro #:optional (old (%distro-age-warning))
                                #:key (suggested-command
                                       "guix package -u"))
  "Emit a warning if Guix is older than OLD seconds."
  (define (seconds->days seconds)
    (round (/ seconds (* 3600 24))))

  (define age
    (match (current-profile-date)
      (#f    #f)
      (date  (- (time-second (current-time time-utc))
                date))))

  (when (and age (>= age old))
    (warning (N_ "Your Guix installation is ~a day old.\n"
                 "Your Guix installation is ~a days old.\n"
                 (seconds->days age))
             (seconds->days age)))
  (when (and (or (not age) (>= age old))
             (not (getenv "GUIX_UNINSTALLED")))
    (warning (G_ "Consider running 'guix pull' followed by
'~a' to get up-to-date packages and security updates.\n")
             suggested-command)
    (newline (guix-warning-port))))

(define %disk-space-warning
  ;; Return a pair of absolute threshold (number of bytes) and relative
  ;; threshold (fraction between 0 and 1) for the free disk space below which
  ;; a warning is emitted.
  ;; GUIX_DISK_SPACE_WARNING can contain both thresholds.  A value in [0;100)
  ;; is a relative threshold, otherwise it's absolute.  The following
  ;; example values are valid:
  ;; - 1GiB;10%      ;1 GiB absolute, and 10% relative.
  ;; - 15G           ;15 GiB absolute, and default relative.
  ;; - 99%           ;99% relative, and default absolute.
  ;; - 99            ;Same.
  ;; - 100           ;100 absolute, and default relative.
  (let* ((default-absolute-threshold (size->number "5GiB"))
         (default-relative-threshold 0.05)
         (percentage->float (lambda (percentage)
                              (or (and=> (string->number
                                          (car (string-split percentage #\%)))
                                         (lambda (n) (/ n 100.0)))
                                  default-relative-threshold)))
         (size->number* (lambda (size)
                          (or (false-if-exception (size->number size))
                              default-absolute-threshold)))
         (absolute? (lambda (size)
                      (not (or (string-suffix? "%" size)
                               (false-if-exception (< (size->number size) 100)))))))
    (make-parameter
     (match (getenv "GUIX_DISK_SPACE_WARNING")
       (#f (list default-absolute-threshold
                 default-relative-threshold))
       (env-string (match (string-split env-string #\;)
                     ((threshold)
                      (if (absolute? threshold)
                          (list (size->number* threshold)
                                default-relative-threshold)
                          (list default-absolute-threshold
                                (percentage->float threshold))))
                     ((threshold1 threshold2)
                      (if (absolute? threshold1)
                          (list (size->number* threshold1)
                                (percentage->float threshold2))
                          (list (size->number* threshold2)
                                (percentage->float threshold1))))))))))

(define* (warn-about-disk-space #:optional profile
                                #:key
                                (thresholds (%disk-space-warning)))
  "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
available.
THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)."
  (define GiB (expt 2 30))

  (let* ((stats      (statfs (%store-prefix)))
         (block-size (file-system-block-size stats))
         (available  (* block-size (file-system-blocks-available stats)))
         (total      (* block-size (file-system-block-count stats)))
         (relative-threshold-in-bytes (* total (cadr thresholds)))
         (absolute-threshold-in-bytes (car thresholds)))
    (when (< available (min relative-threshold-in-bytes
                            absolute-threshold-in-bytes))
      (warning (G_ "only ~,1f GiB of free space available on ~a~%")
               (/ available 1. GiB) (%store-prefix))
      (display-hint (format #f (G_ "Consider deleting old profile
generations and collecting garbage, along these lines:

@example
guix gc --delete-generations=1m
@end example\n"))))))

;;; scripts.scm ends here
Commit	Line	Data
88981dd3	1	;;; GNU Guix --- Functional package management for GNU
71c3c3df	2	;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
88981dd3	3	;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
a82a201a	4	;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
fdef0d85	5	;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
88981dd3 AK	6	;;;
	7	;;; This file is part of GNU Guix.
	8	;;;
	9	;;; GNU Guix is free software; you can redistribute it and/or modify it
	10	;;; under the terms of the GNU General Public License as published by
	11	;;; the Free Software Foundation; either version 3 of the License, or (at
	12	;;; your option) any later version.
	13	;;;
	14	;;; GNU Guix is distributed in the hope that it will be useful, but
	15	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	16	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	17	;;; GNU General Public License for more details.
	18	;;;
	19	;;; You should have received a copy of the GNU General Public License
	20	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	21
	22	(define-module (guix scripts)
a82a201a	23	#:use-module (guix grafts)
88981dd3 AK	24	#:use-module (guix utils)
88981dd3 AK	25	#:use-module (guix ui)
430505eb AK	26	#:use-module (guix store)
	27	#:use-module (guix monads)
	28	#:use-module (guix packages)
	29	#:use-module (guix derivations)
795d430d	30	#:use-module ((guix profiles) #:select (%profile-directory))
55da450a	31	#:autoload (guix describe) (current-profile-date)
62a14bd2	32	#:use-module (guix build syscalls)
88981dd3	33	#:use-module (srfi srfi-1)
7fd952e0	34	#:use-module (srfi srfi-19)
88981dd3 AK	35	#:use-module (srfi srfi-37)
	36	#:use-module (ice-9 match)
	37	#:export (args-fold*
430505eb AK	38	parse-command-line
430505eb AK	39	maybe-build
ad8b83bd	40	build-package
7fd952e0 LC	41	build-package-source
7fd952e0 LC	42	%distro-age-warning
62a14bd2 LC	43	warn-about-old-distro
	44	%disk-space-warning
	45	warn-about-disk-space))
88981dd3 AK	46
	47	;;; Commentary:
	48	;;;
	49	;;; General code for Guix scripts.
	50	;;;
	51	;;; Code:
	52
fdef0d85	53	(define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
88981dd3 AK	54	"A wrapper on top of `args-fold' that does proper user-facing error
	55	reporting."
	56	(catch 'misc-error
	57	(lambda ()
fdef0d85	58	(apply args-fold args options unrecognized-option-proc
88981dd3 AK	59	operand-proc seeds))
	60	(lambda (key proc msg args . rest)
	61	;; XXX: MSG is not i18n'd.
69daee23	62	(leave (G_ "invalid argument: ~a~%")
88981dd3 AK	63	(apply format #f msg args)))))
	64
	65	(define (environment-build-options)
	66	"Return additional build options passed as environment variables."
	67	(arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
	68
	69	(define %default-argument-handler
	70	;; The default handler for non-option command-line arguments.
	71	(lambda (arg result)
	72	(alist-cons 'argument arg result)))
	73
	74	(define* (parse-command-line args options seeds
	75	#:key
a1ff7e1d	76	(build-options? #t)
88981dd3	77	(argument-handler %default-argument-handler))
a1ff7e1d LC	78	"Parse the command-line arguments ARGS according to OPTIONS (a list of
	79	SRFI-37 options) and return the result, seeded by SEEDS. When BUILD-OPTIONS?
	80	is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
	81	variable. Command-line options take precedence those passed via
	82	'GUIX_BUILD_OPTIONS'.
88981dd3 AK	83
	84	ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
	85	parameter of 'args-fold'."
	86	(define (parse-options-from args seeds)
	87	;; Actual parsing takes place here.
	88	(apply args-fold* args options
	89	(lambda (opt name arg . rest)
69daee23	90	(leave (G_ "~A: unrecognized option~%") name))
88981dd3 AK	91	argument-handler
	92	seeds))
	93
	94	(call-with-values
	95	(lambda ()
a1ff7e1d LC	96	(if build-options?
	97	(parse-options-from (environment-build-options) seeds)
	98	(apply values seeds)))
88981dd3 AK	99	(lambda seeds
	100	;; ARGS take precedence over what the environment variable specifies.
	101	(parse-options-from args seeds))))
	102
430505eb AK	103	(define* (maybe-build drvs
	104	#:key dry-run? use-substitutes?)
	105	"Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
	106	true."
	107	(with-monad %store-monad
	108	(>>= (show-what-to-build* drvs
	109	#:dry-run? dry-run?
	110	#:use-substitutes? use-substitutes?)
	111	(lambda (_)
	112	(if dry-run?
	113	(return #f)
	114	(built-derivations drvs))))))
	115
	116	(define* (build-package package
	117	#:key dry-run? (use-substitutes? #t)
	118	#:allow-other-keys
	119	#:rest build-options)
	120	"Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
	121	Show what and how will/would be built."
a82a201a	122	(mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
430505eb AK	123	(apply set-build-options*
	124	#:use-substitutes? use-substitutes?
	125	(strip-keyword-arguments '(#:dry-run?) build-options))
a82a201a AK	126	(mlet %store-monad ((derivation (package->derivation
	127	package #:graft? (and (not dry-run?)
	128	grafting?))))
430505eb AK	129	(mbegin %store-monad
	130	(maybe-build (list derivation)
	131	#:use-substitutes? use-substitutes?
	132	#:dry-run? dry-run?)
	133	(return (show-derivation-outputs derivation))))))
	134
ad8b83bd AK	135	(define* (build-package-source package
	136	#:key dry-run? (use-substitutes? #t)
	137	#:allow-other-keys
	138	#:rest build-options)
	139	"Build PACKAGE source using BUILD-OPTIONS."
	140	(mbegin %store-monad
	141	(apply set-build-options*
	142	#:use-substitutes? use-substitutes?
	143	(strip-keyword-arguments '(#:dry-run?) build-options))
	144	(mlet %store-monad ((derivation (origin->derivation
	145	(package-source package))))
	146	(mbegin %store-monad
	147	(maybe-build (list derivation)
	148	#:use-substitutes? use-substitutes?
	149	#:dry-run? dry-run?)
	150	(return (show-derivation-outputs derivation))))))
	151
7fd952e0 LC	152	(define %distro-age-warning
	153	;; The age (in seconds) above which we warn that the distro is too old.
	154	(make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
	155	string->duration)
	156	(#f (* 7 24 3600))
	157	(age (time-second age)))))
	158
	159	(define* (warn-about-old-distro #:optional (old (%distro-age-warning))
	160	#:key (suggested-command
	161	"guix package -u"))
	162	"Emit a warning if Guix is older than OLD seconds."
55da450a LC	163	(define (seconds->days seconds)
	164	(round (/ seconds (* 3600 24))))
	165
	166	(define age
	167	(match (current-profile-date)
	168	(#f #f)
	169	(date (- (time-second (current-time time-utc))
	170	date))))
	171
	172	(when (and age (>= age old))
	173	(warning (N_ "Your Guix installation is ~a day old.\n"
	174	"Your Guix installation is ~a days old.\n"
	175	(seconds->days age))
	176	(seconds->days age)))
9e5f2060 LC	177	(when (and (or (not age) (>= age old))
9e5f2060 LC	178	(not (getenv "GUIX_UNINSTALLED")))
55da450a	179	(warning (G_ "Consider running 'guix pull' followed by
7fd952e0	180	'~a' to get up-to-date packages and security updates.\n")
55da450a LC	181	suggested-command)
55da450a LC	182	(newline (guix-warning-port))))
7fd952e0	183
62a14bd2	184	(define %disk-space-warning
fb7eec3a PN	185	;; Return a pair of absolute threshold (number of bytes) and relative
	186	;; threshold (fraction between 0 and 1) for the free disk space below which
	187	;; a warning is emitted.
	188	;; GUIX_DISK_SPACE_WARNING can contain both thresholds. A value in [0;100)
	189	;; is a relative threshold, otherwise it's absolute. The following
	190	;; example values are valid:
	191	;; - 1GiB;10% ;1 GiB absolute, and 10% relative.
	192	;; - 15G ;15 GiB absolute, and default relative.
	193	;; - 99% ;99% relative, and default absolute.
	194	;; - 99 ;Same.
	195	;; - 100 ;100 absolute, and default relative.
	196	(let* ((default-absolute-threshold (size->number "5GiB"))
	197	(default-relative-threshold 0.05)
	198	(percentage->float (lambda (percentage)
	199	(or (and=> (string->number
	200	(car (string-split percentage #\%)))
	201	(lambda (n) (/ n 100.0)))
	202	default-relative-threshold)))
	203	(size->number* (lambda (size)
	204	(or (false-if-exception (size->number size))
	205	default-absolute-threshold)))
	206	(absolute? (lambda (size)
	207	(not (or (string-suffix? "%" size)
	208	(false-if-exception (< (size->number size) 100)))))))
	209	(make-parameter
	210	(match (getenv "GUIX_DISK_SPACE_WARNING")
	211	(#f (list default-absolute-threshold
	212	default-relative-threshold))
	213	(env-string (match (string-split env-string #\;)
	214	((threshold)
	215	(if (absolute? threshold)
	216	(list (size->number* threshold)
	217	default-relative-threshold)
	218	(list default-absolute-threshold
	219	(percentage->float threshold))))
	220	((threshold1 threshold2)
	221	(if (absolute? threshold1)
	222	(list (size->number* threshold1)
	223	(percentage->float threshold2))
	224	(list (size->number* threshold2)
	225	(percentage->float threshold1))))))))))
62a14bd2 LC	226
	227	(define* (warn-about-disk-space #:optional profile
	228	#:key
fb7eec3a	229	(thresholds (%disk-space-warning)))
62a14bd2	230	"Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
fb7eec3a	231	available.
71c3c3df LC	232	THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)."
	233	(define GiB (expt 2 30))
	234
62a14bd2 LC	235	(let* ((stats (statfs (%store-prefix)))
	236	(block-size (file-system-block-size stats))
	237	(available (* block-size (file-system-blocks-available stats)))
	238	(total (* block-size (file-system-block-count stats)))
fb7eec3a	239	(relative-threshold-in-bytes (* total (cadr thresholds)))
71c3c3df	240	(absolute-threshold-in-bytes (car thresholds)))
1d24cc6d	241	(when (< available (min relative-threshold-in-bytes
fb7eec3a PN	242	absolute-threshold-in-bytes))
fb7eec3a PN	243	(warning (G_ "only ~,1f GiB of free space available on ~a~%")
71c3c3df	244	(/ available 1. GiB) (%store-prefix))
9c074f61	245	(display-hint (format #f (G_ "Consider deleting old profile
62a14bd2 LC	246	generations and collecting garbage, along these lines:
	247
	248	@example
9c074f61	249	guix gc --delete-generations=1m
fb7eec3a	250	@end example\n"))))))
62a14bd2	251
88981dd3	252	;;; scripts.scm ends here