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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017, 2018 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))
  #: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."
  (let-syntax ((false-if-not-found
                (syntax-rules ()
                  ((_ exp)
                   (catch 'system-error
                     (lambda ()
                       exp)
                     (lambda args
                       (if (= ENOENT (system-error-errno args))
                           #f
                           (apply throw args))))))))
    (define (seconds->days seconds)
      (round (/ seconds (* 3600 24))))

    (define age
      (match (false-if-not-found
              (lstat (string-append %profile-directory "/current-guix")))
        (#f    #f)
        (stat  (- (time-second (current-time time-utc))
                  (stat:mtime stat)))))

    (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 (or (not age) (>= age old))
      (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))
      (if profile
          (display-hint (format #f (G_ "Consider deleting old profile
generations and collecting garbage, along these lines:

@example
guix package -p ~s --delete-generations=1m
guix gc
@end example\n")
                                profile))
          (display-hint (G_ "Consider running @command{guix gc} to free
space."))))))

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