From 62a14bd26f2ed7cf416183528dcca4b1b29aaf0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 23 Oct 2018 00:56:25 +0200 Subject: scripts: Suggest running 'guix gc' when we're short on disk space. * guix/scripts.scm (%disk-space-warning): New variable. (warn-about-disk-space): New procedure. * guix/scripts/package.scm (build-and-use-profile): Use it. * guix/scripts/system.scm (process-action): Likewise. --- guix/scripts.scm | 38 +++++++++++++++++++++++++++++++++++++- guix/scripts/package.scm | 4 +++- guix/scripts/system.scm | 3 ++- 3 files changed, 42 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index 98751bc812..5e20ecd92c 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -27,6 +27,7 @@ #: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) @@ -37,7 +38,9 @@ build-package build-package-source %distro-age-warning - warn-about-old-distro)) + warn-about-old-distro + %disk-space-warning + warn-about-disk-space)) ;;; Commentary: ;;; @@ -186,4 +189,37 @@ Show what and how will/would be built." 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 diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5d146b8427..500fc9ac90 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -164,7 +164,9 @@ do not treat collisions in MANIFEST as an error." count) count) (display-search-paths entries (list profile) - #:kind 'prefix)))))))) + #:kind 'prefix))) + + (warn-about-disk-space profile)))))) ;;; diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f9af38b7c5..d2be0cf8fb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1161,7 +1161,8 @@ resulting from command-line parsing." #:target target #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) - #:system system)))) + #:system system)) + (warn-about-disk-space))) (define (resolve-subcommand name) (let ((module (resolve-interface -- cgit v1.2.3 From fdc4f665dc91005f95b3a643fa8fc2fa9f9863d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Oct 2018 20:04:49 +0200 Subject: profiles: Fix typo in exports. * guix/profiles.scm (&profile-collistion-error): Fix typo in export list. --- guix/profiles.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 89e92ea2ba..ba4446bc2f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -56,7 +56,7 @@ profile-error-profile &profile-not-found-error profile-not-found-error? - &profile-collistion-error + &profile-collision-error profile-collision-error? profile-collision-error-entry profile-collision-error-conflict -- cgit v1.2.3 From 46727e3a9d47f4c525d726ee61410dcf1745ca57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Oct 2018 23:51:56 +0200 Subject: pack: Remove unused variable. * guix/scripts/pack.scm (self-contained-tarball)[libgcrypt]: Remove. --- guix/scripts/pack.scm | 4 ---- 1 file changed, 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index b7b4e22bbe..392e4b5344 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -117,10 +117,6 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define libgcrypt - (module-ref (resolve-interface '(gnu packages gnupg)) - 'libgcrypt)) - (define schema (and localstatedir? (local-file (search-path %load-path -- cgit v1.2.3 From 003789e837d8524edf524e25fd753dbd801b583f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 27 Oct 2018 12:52:47 +0200 Subject: pack: Hide 'zip' colliding binding. * guix/scripts/pack.scm: Hide 'zip' from (gnu packages compression). --- guix/scripts/pack.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 392e4b5344..83bfa4ce00 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -38,7 +38,7 @@ #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) - #:use-module (gnu packages compression) + #:use-module ((gnu packages compression) #:hide (zip)) #:use-module (gnu packages guile) #:use-module (gnu packages base) #:autoload (gnu packages package-management) (guix) -- cgit v1.2.3 From 932d1600564cbf359a6ccd1086b968a934bef8e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 27 Oct 2018 15:45:45 +0200 Subject: gexp: 'gexp-modules' now consistently deletes duplicates. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Clément Lassieur . * guix/gexp.scm (gexp-attribute): Add 'equal?' optional parameter; pass it to 'delete-duplicates'. (gexp-modules)[module=?]: New procedure. Pass it to 'gexp-attribute'. * tests/gexp.scm ("gexp-modules deletes duplicates"): New test. --- guix/gexp.scm | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index ba0d642b17..537875b6b7 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -506,9 +506,10 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! write-gexp-output) -(define (gexp-attribute gexp self-attribute) +(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?)) "Recurse on GEXP and the expressions it refers to, summing the items -returned by SELF-ATTRIBUTE, a procedure that takes a gexp." +returned by SELF-ATTRIBUTE, a procedure that takes a gexp. Use EQUAL? as the +second argument to 'delete-duplicates'." (if (gexp? gexp) (delete-duplicates (append (self-attribute gexp) @@ -524,13 +525,29 @@ returned by SELF-ATTRIBUTE, a procedure that takes a gexp." lst)) (_ '())) - (gexp-references gexp)))) + (gexp-references gexp))) + equal?) '())) ;plain Scheme data type (define (gexp-modules gexp) "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty list." - (gexp-attribute gexp gexp-self-modules)) + (define (module=? m1 m2) + ;; Return #t when M1 equals M2. Special-case '=>' specs because their + ;; right-hand side may not be comparable with 'equal?': it's typically a + ;; file-like object that embeds a gexp, which in turn embeds closure; + ;; those closures may be 'eq?' when running compiled code but are unlikely + ;; to be 'eq?' when running on 'eval'. Ignore the right-hand side to + ;; avoid this discrepancy. + (match m1 + (((name1 ...) '=> _) + (match m2 + (((name2 ...) '=> _) (equal? name1 name2)) + (_ #f))) + (_ + (equal? m1 m2)))) + + (gexp-attribute gexp gexp-self-modules module=?)) (define (gexp-extensions gexp) "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? -- cgit v1.2.3 From 69b0a847fbeaa104e927e4fd2a231fb4fc98a40f Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Sat, 22 Sep 2018 22:18:50 +0530 Subject: import: hackage: Do not repeat inputs in native-inputs. * guix/import/hackage.scm (hackage-module->sexp): Do not repeat inputs again in native-inputs. native-inputs should only contain packages that are not already listed in inputs. --- guix/import/hackage.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 766a0b53f1..48db764b3c 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -215,15 +215,18 @@ representation of a Cabal file as produced by 'read-cabal'." cabal)) (define hackage-native-dependencies - ((compose (cut filter-dependencies <> - (cabal-package-name cabal)) - ;; FIXME: Check include-test-dependencies? - (lambda (cabal) - (append (if include-test-dependencies? - (cabal-test-dependencies->names cabal) - '()) - (cabal-custom-setup-dependencies->names cabal)))) - cabal)) + (lset-difference + equal? + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + ;; FIXME: Check include-test-dependencies? + (lambda (cabal) + (append (if include-test-dependencies? + (cabal-test-dependencies->names cabal) + '()) + (cabal-custom-setup-dependencies->names cabal)))) + cabal) + hackage-dependencies)) (define dependencies (map (lambda (name) -- cgit v1.2.3 From 63eb2b899be7ac857454442e09d0ebd23fe4f871 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Oct 2018 11:20:08 +0200 Subject: Add 'guix processes'. * guix/scripts/processes.scm, tests/processes.scm: New files. * Makefile.am (MODULES): Add the former. (SCM_TESTS): Add the latter. * po/guix/POTFILES.in: Add guix/scripts/processes.scm. * doc/guix.texi (Invoking guix processes): New node. (Invoking guix-daemon): Reference it. --- guix/scripts/processes.scm | 223 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 223 insertions(+) create mode 100644 guix/scripts/processes.scm (limited to 'guix') diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm new file mode 100644 index 0000000000..6a2f603599 --- /dev/null +++ b/guix/scripts/processes.scm @@ -0,0 +1,223 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts processes) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-37) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (process? + process-id + process-parent-id + process-command + processes + + daemon-session? + daemon-session-process + daemon-session-client + daemon-session-children + daemon-session-locks-held + daemon-sessions + + guix-processes)) + +;; Process as can be found in /proc on GNU/Linux. +(define-record-type + (process id parent command) + process? + (id process-id) ;integer + (parent process-parent-id) ;integer | #f + (command process-command)) ;list of strings + +(define (write-process process port) + (format port "#" (process-id process))) + +(set-record-type-printer! write-process) + +(define (read-status-ppid port) + "Read the PPID from PORT, an input port on a /proc/PID/status file. Return +#f for PID 1 and kernel pseudo-processes." + (let loop () + (match (read-line port) + ((? eof-object?) #f) + (line + (if (string-prefix? "PPid:" line) + (string->number (string-trim-both (string-drop line 5))) + (loop)))))) + +(define %not-nul + (char-set-complement (char-set #\nul))) + +(define (read-command-line port) + "Read the zero-split command line from PORT, a /proc/PID/cmdline file, and +return it as a list." + (string-tokenize (read-string port) %not-nul)) + +(define (processes) + "Return a list of process records representing the currently alive +processes." + ;; This assumes a Linux-compatible /proc file system. There exists one for + ;; GNU/Hurd. + (filter-map (lambda (pid) + ;; There's a TOCTTOU race here. If we get ENOENT, simply + ;; ignore PID. + (catch 'system-error + (lambda () + (define ppid + (call-with-input-file (string-append "/proc/" pid "/status") + read-status-ppid)) + (define command + (call-with-input-file (string-append "/proc/" pid "/cmdline") + read-command-line)) + (process (string->number pid) ppid command)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + (scandir "/proc" string->number))) + +(define (process-open-files process) + "Return the list of files currently open by PROCESS." + (let ((directory (string-append "/proc/" + (number->string (process-id process)) + "/fd"))) + (map (lambda (fd) + (readlink (string-append directory "/" fd))) + (or (scandir directory string->number) '())))) + +;; Daemon session. +(define-record-type + (daemon-session process client children locks) + daemon-session? + (process daemon-session-process) ; + (client daemon-session-client) ; + (children daemon-session-children) ;list of + (locks daemon-session-locks-held)) ;list of strings + +(define (daemon-sessions) + "Return two values: the list of denoting the currently +active sessions, and the master 'guix-daemon' process." + (define (lock-file? file) + (and (string-prefix? (%store-prefix) file) + (string-suffix? ".lock" file))) + + (let* ((processes (processes)) + (daemons (filter (lambda (process) + (match (process-command process) + ((argv0 _ ...) + (string=? (basename argv0) "guix-daemon")) + (_ #f))) + processes)) + (children (filter (lambda (process) + (match (process-command process) + ((argv0 (= string->number argv1) _ ...) + (integer? argv1)) + (_ #f))) + daemons)) + (master (remove (lambda (process) + (memq process children)) + daemons))) + (define (lookup-process pid) + (find (lambda (process) + (and (process-id process) + (= pid (process-id process)))) + processes)) + + (define (lookup-children pid) + (filter (lambda (process) + (and (process-parent-id process) + (= pid (process-parent-id process)))) + processes)) + + (values (map (lambda (process) + (match (process-command process) + ((argv0 (= string->number client) _ ...) + (let ((files (process-open-files process))) + (daemon-session process + (lookup-process client) + (lookup-children (process-id process)) + (filter lock-file? files)))))) + children) + master))) + +(define (daemon-session->recutils session port) + "Display SESSION information in recutils format on PORT." + (format port "SessionPID: ~a~%" + (process-id (daemon-session-process session))) + (format port "ClientPID: ~a~%" + (process-id (daemon-session-client session))) + (format port "ClientCommand:~{ ~a~}~%" + (process-command (daemon-session-client session))) + (for-each (lambda (lock) + (format port "LockHeld: ~a~%" lock)) + (daemon-session-locks-held session)) + (for-each (lambda (process) + (format port "ChildProcess: ~a:~{ ~a~}~%" + (process-id process) + (process-command process))) + (daemon-session-children session))) + + +;;; +;;; Options. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix processes"))))) + +(define (show-help) + (display (G_ "Usage: guix processes +List the current Guix sessions and their processes.")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-processes . args) + (define options + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + cons + '())) + + (for-each (lambda (session) + (daemon-session->recutils session (current-output-port)) + (newline)) + (daemon-sessions))) -- cgit v1.2.3 From 2f18b7329d9260cbada8cdec081765adfa82a5f4 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 24 Oct 2018 08:49:50 -0400 Subject: git-download: Print a message when falling back to a full fetch. Otherwise the user might believe that git-fetch stalled, observing the lack of output following a 'fatal' git error message (see: https://debbugs.gnu.org/33100). * guix/build/git.scm (git-fetch): Print message when falling back to a full fetch. --- guix/build/git.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index 14d415a6f8..2d1700a9b9 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -45,6 +45,8 @@ recursively. Return #t on success, #f otherwise." (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) (invoke git-command "checkout" "FETCH_HEAD") (begin + (setvbuf (current-output-port) 'line) + (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") (invoke git-command "fetch" "origin") (invoke git-command "checkout" commit))) (when recursive? -- cgit v1.2.3