guix/scripts/gc.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2015 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 store)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 regex)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (srfi srfi-37)
  27   #:export (guix-gc))
  28
  29 \f
  30 ;;;
  31 ;;; Command-line options.
  32 ;;;
  33
  34 (define %default-options
  35   ;; Alist of default option values.
  36   `((action . collect-garbage)))
  37
  38 (define (show-help)
  39   (display (_ "Usage: guix gc [OPTION]... PATHS...
  40 Invoke the garbage collector.\n"))
  41   (display (_ "
  42   -C, --collect-garbage[=MIN]
  43                          collect at least MIN bytes of garbage"))
  44   (display (_ "
  45   -d, --delete           attempt to delete PATHS"))
  46   (display (_ "
  47       --optimize         optimize the store by deduplicating identical files"))
  48   (display (_ "
  49       --list-dead        list dead paths"))
  50   (display (_ "
  51       --list-live        list live paths"))
  52   (newline)
  53   (display (_ "
  54       --references       list the references of PATHS"))
  55   (display (_ "
  56   -R, --requisites       list the requisites of PATHS"))
  57   (display (_ "
  58       --referrers        list the referrers of PATHS"))
  59   (newline)
  60   (display (_ "
  61       --verify[=OPTS]    verify the integrity of the store; OPTS is a
  62                          comma-separated combination of 'repair' and
  63                          'contents'"))
  64   (newline)
  65   (display (_ "
  66   -h, --help             display this help and exit"))
  67   (display (_ "
  68   -V, --version          display version information and exit"))
  69   (newline)
  70   (show-bug-report-information))
  71
  72 (define %options
  73   ;; Specification of the command-line options.
  74   (list (option '(#\h "help") #f #f
  75                 (lambda args
  76                   (show-help)
  77                   (exit 0)))
  78         (option '(#\V "version") #f #f
  79                 (lambda args
  80                   (show-version-and-exit "guix gc")))
  81
  82         (option '(#\C "collect-garbage") #f #t
  83                 (lambda (opt name arg result)
  84                   (let ((result (alist-cons 'action 'collect-garbage
  85                                             (alist-delete 'action result))))
  86                    (match arg
  87                      ((? string?)
  88                       (let ((amount (size->number arg)))
  89                         (if arg
  90                             (alist-cons 'min-freed amount result)
  91                             (leave (_ "invalid amount of storage: ~a~%")
  92                                    arg))))
  93                      (#f result)))))
  94         (option '(#\d "delete") #f #f
  95                 (lambda (opt name arg result)
  96                   (alist-cons 'action 'delete
  97                               (alist-delete 'action result))))
  98         (option '("optimize") #f #f
  99                 (lambda (opt name arg result)
 100                   (alist-cons 'action 'optimize
 101                               (alist-delete 'action result))))
 102         (option '("verify") #f #t
 103                 (let ((not-comma (char-set-complement (char-set #\,))))
 104                   (lambda (opt name arg result)
 105                     (let ((options (if arg
 106                                        (map string->symbol
 107                                             (string-tokenize arg not-comma))
 108                                        '())))
 109                       (alist-cons 'action 'verify
 110                                   (alist-cons 'verify-options options
 111                                               (alist-delete 'action
 112                                                             result)))))))
 113         (option '("list-dead") #f #f
 114                 (lambda (opt name arg result)
 115                   (alist-cons 'action 'list-dead
 116                               (alist-delete 'action result))))
 117         (option '("list-live") #f #f
 118                 (lambda (opt name arg result)
 119                   (alist-cons 'action 'list-live
 120                               (alist-delete 'action result))))
 121         (option '("references") #f #f
 122                 (lambda (opt name arg result)
 123                   (alist-cons 'action 'list-references
 124                               (alist-delete 'action result))))
 125         (option '(#\R "requisites") #f #f
 126                 (lambda (opt name arg result)
 127                   (alist-cons 'action 'list-requisites
 128                               (alist-delete 'action result))))
 129         (option '("referrers") #f #f
 130                 (lambda (opt name arg result)
 131                   (alist-cons 'action 'list-referrers
 132                               (alist-delete 'action result))))))
 133
 134 \f
 135 ;;;
 136 ;;; Entry point.
 137 ;;;
 138
 139 (define (guix-gc . args)
 140   (define (parse-options)
 141     ;; Return the alist of option values.
 142     (args-fold* args %options
 143                 (lambda (opt name arg result)
 144                   (leave (_ "~A: unrecognized option~%") name))
 145                 (lambda (arg result)
 146                   (alist-cons 'argument arg result))
 147                 %default-options))
 148
 149   (define (symlink-target file)
 150     (let ((s (false-if-exception (lstat file))))
 151       (if (and s (eq? 'symlink (stat:type s)))
 152           (symlink-target (readlink file))
 153           file)))
 154
 155   (define (store-directory file)
 156     ;; Return the store directory that holds FILE if it's in the store,
 157     ;; otherwise return FILE.
 158     (or (and=> (string-match (string-append "^" (regexp-quote (%store-prefix))
 159                                             "/([^/]+)")
 160                              file)
 161                (compose (cut string-append (%store-prefix) "/" <>)
 162                         (cut match:substring <> 1)))
 163         file))
 164
 165   (with-error-handling
 166     (let* ((opts  (parse-options))
 167            (store (open-connection))
 168            (paths (filter-map (match-lambda
 169                                (('argument . arg) arg)
 170                                (_ #f))
 171                               opts)))
 172       (define (list-relatives relatives)
 173         (for-each (compose (lambda (path)
 174                              (for-each (cut simple-format #t "~a~%" <>)
 175                                        (relatives store path)))
 176                            store-directory
 177                            symlink-target)
 178                   paths))
 179
 180       (case (assoc-ref opts 'action)
 181         ((collect-garbage)
 182          (let ((min-freed (assoc-ref opts 'min-freed)))
 183            (if min-freed
 184                (collect-garbage store min-freed)
 185                (collect-garbage store))))
 186         ((delete)
 187          (delete-paths store (map direct-store-path paths)))
 188         ((list-references)
 189          (list-relatives references))
 190         ((list-requisites)
 191          (list-relatives requisites))
 192         ((list-referrers)
 193          (list-relatives referrers))
 194         ((optimize)
 195          (optimize-store store))
 196         ((verify)
 197          (let ((options (assoc-ref opts 'verify-options)))
 198            (exit
 199             (verify-store store
 200                           #:check-contents? (memq 'contents options)
 201                           #:repair? (memq 'repair options)))))
 202         ((list-dead)
 203          (for-each (cut simple-format #t "~a~%" <>)
 204                    (dead-paths store)))
 205         ((list-live)
 206          (for-each (cut simple-format #t "~a~%" <>)
 207                    (live-paths store)))))))