guix/scripts/gc.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2015, 2016 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   #:autoload   (guix build syscalls) (statfs)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 regex)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-11)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (srfi srfi-37)
  30   #:export (guix-gc))
  31
  32 \f
  33 ;;;
  34 ;;; Command-line options.
  35 ;;;
  36
  37 (define %default-options
  38   ;; Alist of default option values.
  39   `((action . collect-garbage)))
  40
  41 (define (show-help)
  42   (display (G_ "Usage: guix gc [OPTION]... PATHS...
  43 Invoke the garbage collector.\n"))
  44   (display (G_ "
  45   -C, --collect-garbage[=MIN]
  46                          collect at least MIN bytes of garbage"))
  47   (display (G_ "
  48   -F, --free-space=FREE  attempt to reach FREE available space in the store"))
  49   (display (G_ "
  50   -d, --delete           attempt to delete PATHS"))
  51   (display (G_ "
  52       --optimize         optimize the store by deduplicating identical files"))
  53   (display (G_ "
  54       --list-dead        list dead paths"))
  55   (display (G_ "
  56       --list-live        list live paths"))
  57   (newline)
  58   (display (G_ "
  59       --references       list the references of PATHS"))
  60   (display (G_ "
  61   -R, --requisites       list the requisites of PATHS"))
  62   (display (G_ "
  63       --referrers        list the referrers of PATHS"))
  64   (newline)
  65   (display (G_ "
  66       --verify[=OPTS]    verify the integrity of the store; OPTS is a
  67                          comma-separated combination of 'repair' and
  68                          'contents'"))
  69   (display (G_ "
  70       --list-failures    list cached build failures"))
  71   (display (G_ "
  72       --clear-failures   remove PATHS from the set of cached failures"))
  73   (newline)
  74   (display (G_ "
  75   -h, --help             display this help and exit"))
  76   (display (G_ "
  77   -V, --version          display version information and exit"))
  78   (newline)
  79   (show-bug-report-information))
  80
  81 (define %options
  82   ;; Specification of the command-line options.
  83   (list (option '(#\h "help") #f #f
  84                 (lambda args
  85                   (show-help)
  86                   (exit 0)))
  87         (option '(#\V "version") #f #f
  88                 (lambda args
  89                   (show-version-and-exit "guix gc")))
  90
  91         (option '(#\C "collect-garbage") #f #t
  92                 (lambda (opt name arg result)
  93                   (let ((result (alist-cons 'action 'collect-garbage
  94                                             (alist-delete 'action result))))
  95                    (match arg
  96                      ((? string?)
  97                       (let ((amount (size->number arg)))
  98                         (if arg
  99                             (alist-cons 'min-freed amount result)
 100                             (leave (G_ "invalid amount of storage: ~a~%")
 101                                    arg))))
 102                      (#f result)))))
 103         (option '(#\F "free-space") #t #f
 104                 (lambda (opt name arg result)
 105                   (alist-cons 'free-space (size->number arg) result)))
 106         (option '(#\d "delete") #f #f
 107                 (lambda (opt name arg result)
 108                   (alist-cons 'action 'delete
 109                               (alist-delete 'action result))))
 110         (option '("optimize") #f #f
 111                 (lambda (opt name arg result)
 112                   (alist-cons 'action 'optimize
 113                               (alist-delete 'action result))))
 114         (option '("verify") #f #t
 115                 (let ((not-comma (char-set-complement (char-set #\,))))
 116                   (lambda (opt name arg result)
 117                     (let ((options (if arg
 118                                        (map string->symbol
 119                                             (string-tokenize arg not-comma))
 120                                        '())))
 121                       (alist-cons 'action 'verify
 122                                   (alist-cons 'verify-options options
 123                                               (alist-delete 'action
 124                                                             result)))))))
 125         (option '("list-dead") #f #f
 126                 (lambda (opt name arg result)
 127                   (alist-cons 'action 'list-dead
 128                               (alist-delete 'action result))))
 129         (option '("list-live") #f #f
 130                 (lambda (opt name arg result)
 131                   (alist-cons 'action 'list-live
 132                               (alist-delete 'action result))))
 133         (option '("references") #f #f
 134                 (lambda (opt name arg result)
 135                   (alist-cons 'action 'list-references
 136                               (alist-delete 'action result))))
 137         (option '(#\R "requisites") #f #f
 138                 (lambda (opt name arg result)
 139                   (alist-cons 'action 'list-requisites
 140                               (alist-delete 'action result))))
 141         (option '("referrers") #f #f
 142                 (lambda (opt name arg result)
 143                   (alist-cons 'action 'list-referrers
 144                               (alist-delete 'action result))))
 145         (option '("list-failures") #f #f
 146                 (lambda (opt name arg result)
 147                   (alist-cons 'action 'list-failures
 148                               (alist-delete 'action result))))
 149         (option '("clear-failures") #f #f
 150                 (lambda (opt name arg result)
 151                   (alist-cons 'action 'clear-failures
 152                               (alist-delete 'action result))))))
 153
 154 \f
 155 ;;;
 156 ;;; Entry point.
 157 ;;;
 158
 159 (define (guix-gc . args)
 160   (define (parse-options)
 161     ;; Return the alist of option values.
 162     (args-fold* args %options
 163                 (lambda (opt name arg result)
 164                   (leave (G_ "~A: unrecognized option~%") name))
 165                 (lambda (arg result)
 166                   (alist-cons 'argument arg result))
 167                 %default-options))
 168
 169   (define (symlink-target file)
 170     (let ((s (false-if-exception (lstat file))))
 171       (if (and s (eq? 'symlink (stat:type s)))
 172           (symlink-target (readlink file))
 173           file)))
 174
 175   (define (store-directory file)
 176     ;; Return the store directory that holds FILE if it's in the store,
 177     ;; otherwise return FILE.
 178     (or (and=> (string-match (string-append "^" (regexp-quote (%store-prefix))
 179                                             "/([^/]+)")
 180                              file)
 181                (compose (cut string-append (%store-prefix) "/" <>)
 182                         (cut match:substring <> 1)))
 183         file))
 184
 185   (define (ensure-free-space store space)
 186     ;; Attempt to have at least SPACE bytes available in STORE.
 187     (let* ((fs    (statfs (%store-prefix)))
 188            (free  (* (file-system-block-size fs)
 189                      (file-system-blocks-available fs))))
 190       (if (> free space)
 191           (info (G_ "already ~h bytes available on ~a, nothing to do~%")
 192                 free (%store-prefix))
 193           (let ((to-free (- space free)))
 194             (info (G_ "freeing ~h bytes~%") to-free)
 195             (collect-garbage store to-free)))))
 196
 197   (with-error-handling
 198     (let* ((opts  (parse-options))
 199            (store (open-connection))
 200            (paths (filter-map (match-lambda
 201                                (('argument . arg) arg)
 202                                (_ #f))
 203                               opts)))
 204       (define (assert-no-extra-arguments)
 205         (unless (null? paths)
 206           (leave (G_ "extraneous arguments: ~{~a ~}~%") paths)))
 207
 208       (define (list-relatives relatives)
 209         (for-each (compose (lambda (path)
 210                              (for-each (cut simple-format #t "~a~%" <>)
 211                                        (relatives store path)))
 212                            store-directory
 213                            symlink-target)
 214                   paths))
 215
 216       (case (assoc-ref opts 'action)
 217         ((collect-garbage)
 218          (assert-no-extra-arguments)
 219          (let ((min-freed  (assoc-ref opts 'min-freed))
 220                (free-space (assoc-ref opts 'free-space)))
 221            (cond
 222             (free-space
 223              (ensure-free-space store free-space))
 224             (min-freed
 225              (let-values (((paths freed) (collect-garbage store min-freed)))
 226               (info (G_ "freed ~h bytes~%") freed)))
 227             (else
 228              (let-values (((paths freed) (collect-garbage store)))
 229               (info (G_ "freed ~h bytes~%") freed))))))
 230         ((delete)
 231          (delete-paths store (map direct-store-path paths)))
 232         ((list-references)
 233          (list-relatives references))
 234         ((list-requisites)
 235          (list-relatives (lambda (store item)
 236                            (requisites store (list item)))))
 237         ((list-referrers)
 238          (list-relatives referrers))
 239         ((optimize)
 240          (assert-no-extra-arguments)
 241          (optimize-store store))
 242         ((verify)
 243          (assert-no-extra-arguments)
 244          (let ((options (assoc-ref opts 'verify-options)))
 245            (exit
 246             (verify-store store
 247                           #:check-contents? (memq 'contents options)
 248                           #:repair? (memq 'repair options)))))
 249         ((list-failures)
 250          (for-each (cut simple-format #t "~a~%" <>)
 251                    (query-failed-paths store)))
 252         ((clear-failures)
 253          (clear-failed-paths store (map direct-store-path paths)))
 254         ((list-dead)
 255          (for-each (cut simple-format #t "~a~%" <>)
 256                    (dead-paths store)))
 257         ((list-live)
 258          (for-each (cut simple-format #t "~a~%" <>)
 259                    (live-paths store)))))))