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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;;
;;; 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* 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 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
  ;; The fraction (between 0 and 1) of free disk space below which a warning
  ;; is emitted.
  (make-parameter (match (and=> (getenv "GUIX_DISK_SPACE_WARNING")
                                string->number)
                    (#f        .05)               ;5%
                    (threshold (/ threshold 100.)))))

(define* (warn-about-disk-space #:optional profile
                                #:key
                                (threshold (%disk-space-warning)))
  "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
available."
  (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)))
         (ratio      (/ available total 1.)))
    (when (< ratio threshold)
      (warning (G_ "only ~,1f% of free space available on ~a~%")
               (* ratio 100) (%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")
                            profile)))))

;;; scripts.scm ends here
Commit	Line	Data
88981dd3	1	;;; GNU Guix --- Functional package management for GNU
55da450a	2	;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 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>
88981dd3 AK	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)
a82a201a	22	#:use-module (guix grafts)
88981dd3 AK	23	#:use-module (guix utils)
88981dd3 AK	24	#:use-module (guix ui)
430505eb AK	25	#:use-module (guix store)
	26	#:use-module (guix monads)
	27	#:use-module (guix packages)
	28	#:use-module (guix derivations)
795d430d	29	#:use-module ((guix profiles) #:select (%profile-directory))
55da450a	30	#:autoload (guix describe) (current-profile-date)
62a14bd2	31	#:use-module (guix build syscalls)
88981dd3	32	#:use-module (srfi srfi-1)
7fd952e0	33	#:use-module (srfi srfi-19)
88981dd3 AK	34	#:use-module (srfi srfi-37)
	35	#:use-module (ice-9 match)
	36	#:export (args-fold*
430505eb AK	37	parse-command-line
430505eb AK	38	maybe-build
ad8b83bd	39	build-package
7fd952e0 LC	40	build-package-source
7fd952e0 LC	41	%distro-age-warning
62a14bd2 LC	42	warn-about-old-distro
	43	%disk-space-warning
	44	warn-about-disk-space))
88981dd3 AK	45
	46	;;; Commentary:
	47	;;;
	48	;;; General code for Guix scripts.
	49	;;;
	50	;;; Code:
	51
	52	(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
	53	"A wrapper on top of `args-fold' that does proper user-facing error
	54	reporting."
	55	(catch 'misc-error
	56	(lambda ()
	57	(apply args-fold options unrecognized-option-proc
	58	operand-proc seeds))
	59	(lambda (key proc msg args . rest)
	60	;; XXX: MSG is not i18n'd.
69daee23	61	(leave (G_ "invalid argument: ~a~%")
88981dd3 AK	62	(apply format #f msg args)))))
	63
	64	(define (environment-build-options)
	65	"Return additional build options passed as environment variables."
	66	(arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
	67
	68	(define %default-argument-handler
	69	;; The default handler for non-option command-line arguments.
	70	(lambda (arg result)
	71	(alist-cons 'argument arg result)))
	72
	73	(define* (parse-command-line args options seeds
	74	#:key
a1ff7e1d	75	(build-options? #t)
88981dd3	76	(argument-handler %default-argument-handler))
a1ff7e1d LC	77	"Parse the command-line arguments ARGS according to OPTIONS (a list of
	78	SRFI-37 options) and return the result, seeded by SEEDS. When BUILD-OPTIONS?
	79	is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
	80	variable. Command-line options take precedence those passed via
	81	'GUIX_BUILD_OPTIONS'.
88981dd3 AK	82
	83	ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
	84	parameter of 'args-fold'."
	85	(define (parse-options-from args seeds)
	86	;; Actual parsing takes place here.
	87	(apply args-fold* args options
	88	(lambda (opt name arg . rest)
69daee23	89	(leave (G_ "~A: unrecognized option~%") name))
88981dd3 AK	90	argument-handler
	91	seeds))
	92
	93	(call-with-values
	94	(lambda ()
a1ff7e1d LC	95	(if build-options?
	96	(parse-options-from (environment-build-options) seeds)
	97	(apply values seeds)))
88981dd3 AK	98	(lambda seeds
	99	;; ARGS take precedence over what the environment variable specifies.
	100	(parse-options-from args seeds))))
	101
430505eb AK	102	(define* (maybe-build drvs
	103	#:key dry-run? use-substitutes?)
	104	"Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
	105	true."
	106	(with-monad %store-monad
	107	(>>= (show-what-to-build* drvs
	108	#:dry-run? dry-run?
	109	#:use-substitutes? use-substitutes?)
	110	(lambda (_)
	111	(if dry-run?
	112	(return #f)
	113	(built-derivations drvs))))))
	114
	115	(define* (build-package package
	116	#:key dry-run? (use-substitutes? #t)
	117	#:allow-other-keys
	118	#:rest build-options)
	119	"Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
	120	Show what and how will/would be built."
a82a201a	121	(mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
430505eb AK	122	(apply set-build-options*
	123	#:use-substitutes? use-substitutes?
	124	(strip-keyword-arguments '(#:dry-run?) build-options))
a82a201a AK	125	(mlet %store-monad ((derivation (package->derivation
	126	package #:graft? (and (not dry-run?)
	127	grafting?))))
430505eb AK	128	(mbegin %store-monad
	129	(maybe-build (list derivation)
	130	#:use-substitutes? use-substitutes?
	131	#:dry-run? dry-run?)
	132	(return (show-derivation-outputs derivation))))))
	133
ad8b83bd AK	134	(define* (build-package-source package
	135	#:key dry-run? (use-substitutes? #t)
	136	#:allow-other-keys
	137	#:rest build-options)
	138	"Build PACKAGE source using BUILD-OPTIONS."
	139	(mbegin %store-monad
	140	(apply set-build-options*
	141	#:use-substitutes? use-substitutes?
	142	(strip-keyword-arguments '(#:dry-run?) build-options))
	143	(mlet %store-monad ((derivation (origin->derivation
	144	(package-source package))))
	145	(mbegin %store-monad
	146	(maybe-build (list derivation)
	147	#:use-substitutes? use-substitutes?
	148	#:dry-run? dry-run?)
	149	(return (show-derivation-outputs derivation))))))
	150
7fd952e0 LC	151	(define %distro-age-warning
	152	;; The age (in seconds) above which we warn that the distro is too old.
	153	(make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
	154	string->duration)
	155	(#f (* 7 24 3600))
	156	(age (time-second age)))))
	157
	158	(define* (warn-about-old-distro #:optional (old (%distro-age-warning))
	159	#:key (suggested-command
	160	"guix package -u"))
	161	"Emit a warning if Guix is older than OLD seconds."
55da450a LC	162	(define (seconds->days seconds)
	163	(round (/ seconds (* 3600 24))))
	164
	165	(define age
	166	(match (current-profile-date)
	167	(#f #f)
	168	(date (- (time-second (current-time time-utc))
	169	date))))
	170
	171	(when (and age (>= age old))
	172	(warning (N_ "Your Guix installation is ~a day old.\n"
	173	"Your Guix installation is ~a days old.\n"
	174	(seconds->days age))
	175	(seconds->days age)))
9e5f2060 LC	176	(when (and (or (not age) (>= age old))
9e5f2060 LC	177	(not (getenv "GUIX_UNINSTALLED")))
55da450a	178	(warning (G_ "Consider running 'guix pull' followed by
7fd952e0	179	'~a' to get up-to-date packages and security updates.\n")
55da450a LC	180	suggested-command)
55da450a LC	181	(newline (guix-warning-port))))
7fd952e0	182
62a14bd2 LC	183	(define %disk-space-warning
	184	;; The fraction (between 0 and 1) of free disk space below which a warning
	185	;; is emitted.
	186	(make-parameter (match (and=> (getenv "GUIX_DISK_SPACE_WARNING")
	187	string->number)
	188	(#f .05) ;5%
	189	(threshold (/ threshold 100.)))))
	190
	191	(define* (warn-about-disk-space #:optional profile
	192	#:key
	193	(threshold (%disk-space-warning)))
	194	"Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
	195	available."
	196	(let* ((stats (statfs (%store-prefix)))
	197	(block-size (file-system-block-size stats))
	198	(available (* block-size (file-system-blocks-available stats)))
	199	(total (* block-size (file-system-block-count stats)))
	200	(ratio (/ available total 1.)))
	201	(when (< ratio threshold)
	202	(warning (G_ "only ~,1f% of free space available on ~a~%")
	203	(* ratio 100) (%store-prefix))
9c074f61	204	(display-hint (format #f (G_ "Consider deleting old profile
62a14bd2 LC	205	generations and collecting garbage, along these lines:
	206
	207	@example
9c074f61	208	guix gc --delete-generations=1m
62a14bd2	209	@end example\n")
9c074f61	210	profile)))))
62a14bd2	211
88981dd3	212	;;; scripts.scm ends here