guix/scripts/gc.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix scripts gc)
  20   #:use-module (guix ui)
  21   #:use-module (guix scripts)
  22   #:use-module (guix store)
  23   #:use-module (guix store roots)
  24   #:autoload   (guix build syscalls) (free-disk-space)
  25   #:autoload   (guix profiles) (generation-profile
  26                                 profile-generations
  27                                 generation-number)
  28   #:autoload   (guix scripts package) (delete-generations)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 regex)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-11)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (srfi srfi-37)
  35   #:export (guix-gc))
  36
  37 \f
  38 ;;;
  39 ;;; Command-line options.
  40 ;;;
  41
  42 (define %default-options
  43   ;; Alist of default option values.
  44   `((action . collect-garbage)))
  45
  46 (define (show-help)
  47   (display (G_ "Usage: guix gc [OPTION]... PATHS...
  48 Invoke the garbage collector.\n"))
  49   (display (G_ "
  50   -C, --collect-garbage[=MIN]
  51                          collect at least MIN bytes of garbage"))
  52   (display (G_ "
  53   -F, --free-space=FREE  attempt to reach FREE available space in the store"))
  54   (display (G_ "
  55   -d, --delete-generations[=PATTERN]
  56                          delete profile generations matching PATTERN"))
  57   (display (G_ "
  58   -D, --delete           attempt to delete PATHS"))
  59   (display (G_ "
  60       --list-roots       list the user's garbage collector roots"))
  61   (display (G_ "
  62       --list-busy        list store items used by running processes"))
  63   (display (G_ "
  64       --optimize         optimize the store by deduplicating identical files"))
  65   (display (G_ "
  66       --list-dead        list dead paths"))
  67   (display (G_ "
  68       --list-live        list live paths"))
  69   (newline)
  70   (display (G_ "
  71       --references       list the references of PATHS"))
  72   (display (G_ "
  73   -R, --requisites       list the requisites of PATHS"))
  74   (display (G_ "
  75       --referrers        list the referrers of PATHS"))
  76   (display (G_ "
  77       --derivers         list the derivers of PATHS"))
  78   (newline)
  79   (display (G_ "
  80       --verify[=OPTS]    verify the integrity of the store; OPTS is a
  81                          comma-separated combination of 'repair' and
  82                          'contents'"))
  83   (display (G_ "
  84       --list-failures    list cached build failures"))
  85   (display (G_ "
  86       --clear-failures   remove PATHS from the set of cached failures"))
  87   (newline)
  88   (display (G_ "
  89   -h, --help             display this help and exit"))
  90   (display (G_ "
  91   -V, --version          display version information and exit"))
  92   (newline)
  93   (show-bug-report-information))
  94
  95 (define argument->verify-options
  96   (let ((not-comma (char-set-complement (char-set #\,)))
  97         (validate  (lambda (option)
  98                      (unless (memq option '(repair contents))
  99                        (leave (G_ "~a: invalid '--verify' option~%")
 100                               option)))))
 101     (lambda (arg)
 102       "Turn ARG into a list of symbols denoting '--verify' options."
 103       (if arg
 104           (let ((lst (map string->symbol
 105                           (string-tokenize arg not-comma))))
 106             (for-each validate lst)
 107             lst)
 108           '()))))
 109
 110 (define (delete-old-generations store profile pattern)
 111   "Remove the generations of PROFILE that match PATTERN, a duration pattern;
 112 do nothing if none matches.  If PATTERN is #f, delete all generations but the
 113 current one."
 114   (let* ((current (generation-number profile))
 115          (numbers (if (not pattern)
 116                       (profile-generations profile)
 117                       (matching-generations pattern profile
 118                                             #:duration-relation >))))
 119
 120     ;; Make sure we don't inadvertently remove the current generation.
 121     (delete-generations store profile (delv current numbers))))
 122
 123 (define %options
 124   ;; Specification of the command-line options.
 125   (list (option '(#\h "help") #f #f
 126                 (lambda args
 127                   (show-help)
 128                   (exit 0)))
 129         (option '(#\V "version") #f #f
 130                 (lambda args
 131                   (show-version-and-exit "guix gc")))
 132
 133         (option '(#\C "collect-garbage") #f #t
 134                 (lambda (opt name arg result)
 135                   (let ((result (alist-cons 'action 'collect-garbage
 136                                             (alist-delete 'action result))))
 137                    (match arg
 138                      ((? string?)
 139                       (let ((amount (size->number arg)))
 140                         (if arg
 141                             (alist-cons 'min-freed amount result)
 142                             (leave (G_ "invalid amount of storage: ~a~%")
 143                                    arg))))
 144                      (#f result)))))
 145         (option '(#\F "free-space") #t #f
 146                 (lambda (opt name arg result)
 147                   (alist-cons 'free-space (size->number arg) result)))
 148         (option '(#\D "delete") #f #f            ;used to be '-d' (lower case)
 149                 (lambda (opt name arg result)
 150                   (alist-cons 'action 'delete
 151                               (alist-delete 'action result))))
 152         (option '(#\d "delete-generations") #f #t
 153                 (lambda (opt name arg result)
 154                   (if (and arg (store-path? arg))
 155                       (begin
 156                         (warning (G_ "'-d' as an alias for '--delete' \
 157 is deprecated; use '-D'~%"))
 158                         `((action . delete)
 159                           (argument . ,arg)
 160                           (alist-delete 'action result)))
 161                       (begin
 162                         (when (and arg (not (string->duration arg)))
 163                           (leave (G_ "~s does not denote a duration~%")
 164                                  arg))
 165                         (alist-cons 'delete-generations arg result)))))
 166         (option '("optimize") #f #f
 167                 (lambda (opt name arg result)
 168                   (alist-cons 'action 'optimize
 169                               (alist-delete 'action result))))
 170         (option '("verify") #f #t
 171                 (lambda (opt name arg result)
 172                   (let ((options (argument->verify-options arg)))
 173                     (alist-cons 'action 'verify
 174                                 (alist-cons 'verify-options options
 175                                             (alist-delete 'action
 176                                                           result))))))
 177         (option '("list-roots") #f #f
 178                 (lambda (opt name arg result)
 179                   (alist-cons 'action 'list-roots
 180                               (alist-delete 'action result))))
 181         (option '("list-busy") #f #f
 182                 (lambda (opt name arg result)
 183                   (alist-cons 'action 'list-busy
 184                               (alist-delete 'action result))))
 185         (option '("list-dead") #f #f
 186                 (lambda (opt name arg result)
 187                   (alist-cons 'action 'list-dead
 188                               (alist-delete 'action result))))
 189         (option '("list-live") #f #f
 190                 (lambda (opt name arg result)
 191                   (alist-cons 'action 'list-live
 192                               (alist-delete 'action result))))
 193         (option '("references") #f #f
 194                 (lambda (opt name arg result)
 195                   (alist-cons 'action 'list-references
 196                               (alist-delete 'action result))))
 197         (option '(#\R "requisites") #f #f
 198                 (lambda (opt name arg result)
 199                   (alist-cons 'action 'list-requisites
 200                               (alist-delete 'action result))))
 201         (option '("referrers") #f #f
 202                 (lambda (opt name arg result)
 203                   (alist-cons 'action 'list-referrers
 204                               (alist-delete 'action result))))
 205         (option '("derivers") #f #f
 206                 (lambda (opt name arg result)
 207                   (alist-cons 'action 'list-derivers
 208                               (alist-delete 'action result))))
 209         (option '("list-failures") #f #f
 210                 (lambda (opt name arg result)
 211                   (alist-cons 'action 'list-failures
 212                               (alist-delete 'action result))))
 213         (option '("clear-failures") #f #f
 214                 (lambda (opt name arg result)
 215                   (alist-cons 'action 'clear-failures
 216                               (alist-delete 'action result))))))
 217
 218 \f
 219 ;;;
 220 ;;; Entry point.
 221 ;;;
 222
 223 (define-command (guix-gc . args)
 224   (synopsis "invoke the garbage collector")
 225
 226   (define (parse-options)
 227     ;; Return the alist of option values.
 228     (parse-command-line args %options (list %default-options)
 229                         #:build-options? #f))
 230
 231   (define (symlink-target file)
 232     (let ((s (false-if-exception (lstat file))))
 233       (if (and s (eq? 'symlink (stat:type s)))
 234           (symlink-target (readlink file))
 235           file)))
 236
 237   (define (store-directory file)
 238     ;; Return the store directory that holds FILE if it's in the store,
 239     ;; otherwise return FILE.
 240     (or (and=> (string-match (string-append "^" (regexp-quote (%store-prefix))
 241                                             "/([^/]+)")
 242                              file)
 243                (compose (cut string-append (%store-prefix) "/" <>)
 244                         (cut match:substring <> 1)))
 245         file))
 246
 247   (define (ensure-free-space store space)
 248     ;; Attempt to have at least SPACE bytes available in STORE.
 249     (let ((free (free-disk-space (%store-prefix))))
 250       (if (> free space)
 251           (info (G_ "already ~h MiBs available on ~a, nothing to do~%")
 252                 (/ free 1024. 1024.) (%store-prefix))
 253           (let ((to-free (- space free)))
 254             (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
 255             (collect-garbage store to-free)))))
 256
 257   (define (delete-generations store pattern)
 258     ;; Delete the generations matching PATTERN of all the user's profiles.
 259     (let ((profiles (delete-duplicates
 260                      (filter-map (lambda (root)
 261                                    (and (or (zero? (getuid))
 262                                             (user-owned? root))
 263                                         (generation-profile root)))
 264                                  (gc-roots)))))
 265       (for-each (lambda (profile)
 266                   (delete-old-generations store profile pattern))
 267                 profiles)))
 268
 269   (define (list-roots)
 270     ;; List all the user-owned GC roots.
 271     (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
 272                          (gc-roots))))
 273       (for-each (lambda (root)
 274                   (display root)
 275                   (newline))
 276                 roots)))
 277
 278   (define (list-busy)
 279     ;; List store items used by running processes.
 280     (for-each (lambda (item)
 281                 (display item) (newline))
 282               (busy-store-items)))
 283
 284   (with-error-handling
 285     (let* ((opts  (parse-options))
 286            (store (open-connection))
 287            (paths (filter-map (match-lambda
 288                                (('argument . arg) arg)
 289                                (_ #f))
 290                               opts)))
 291       (define (assert-no-extra-arguments)
 292         (unless (null? paths)
 293           (leave (G_ "extraneous arguments: ~{~a ~}~%") paths)))
 294
 295       (define (list-relatives relatives)
 296         (for-each (compose (lambda (path)
 297                              (for-each (cut simple-format #t "~a~%" <>)
 298                                        (relatives store path)))
 299                            store-directory
 300                            symlink-target)
 301                   paths))
 302
 303       (case (assoc-ref opts 'action)
 304         ((collect-garbage)
 305          (assert-no-extra-arguments)
 306          (let ((min-freed  (assoc-ref opts 'min-freed))
 307                (free-space (assoc-ref opts 'free-space)))
 308            (match (assq 'delete-generations opts)
 309              (#f #t)
 310              ((_ . pattern)
 311               (delete-generations store pattern)))
 312            (cond
 313             (free-space
 314              (ensure-free-space store free-space))
 315             (min-freed
 316              (let-values (((paths freed) (collect-garbage store min-freed)))
 317               (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))
 318             (else
 319              (let-values (((paths freed) (collect-garbage store)))
 320               (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))))))
 321         ((list-roots)
 322          (assert-no-extra-arguments)
 323          (list-roots))
 324         ((list-busy)
 325          (assert-no-extra-arguments)
 326          (list-busy))
 327         ((delete)
 328          (delete-paths store (map direct-store-path paths)))
 329         ((list-references)
 330          (list-relatives references))
 331         ((list-requisites)
 332          (list-relatives (lambda (store item)
 333                            (requisites store (list item)))))
 334         ((list-referrers)
 335          (list-relatives referrers))
 336         ((list-derivers)
 337          (list-relatives valid-derivers))
 338         ((optimize)
 339          (assert-no-extra-arguments)
 340          (optimize-store store))
 341         ((verify)
 342          (assert-no-extra-arguments)
 343          (let ((options (assoc-ref opts 'verify-options)))
 344            (exit
 345             (verify-store store
 346                           #:check-contents? (memq 'contents options)
 347                           #:repair? (memq 'repair options)))))
 348         ((list-failures)
 349          (for-each (cut simple-format #t "~a~%" <>)
 350                    (query-failed-paths store)))
 351         ((clear-failures)
 352          (clear-failed-paths store (map direct-store-path paths)))
 353         ((list-dead)
 354          (for-each (cut simple-format #t "~a~%" <>)
 355                    (dead-paths store)))
 356         ((list-live)
 357          (for-each (cut simple-format #t "~a~%" <>)
 358                    (live-paths store)))))))