guix-gc.in

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3
   4 prefix="@prefix@"
   5 datarootdir="@datarootdir@"
   6
   7 GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
   8 export GUILE_LOAD_COMPILED_PATH
   9
  10 main='(module-ref (resolve-interface '\''(guix-gc)) '\'guix-gc')'
  11 exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
  12          -c "(apply $main (cdr (command-line)))" "$@"
  13 !#
  14 ;;; GNU Guix --- Functional package management for GNU
  15 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
  16 ;;;
  17 ;;; This file is part of GNU Guix.
  18 ;;;
  19 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  20 ;;; under the terms of the GNU General Public License as published by
  21 ;;; the Free Software Foundation; either version 3 of the License, or (at
  22 ;;; your option) any later version.
  23 ;;;
  24 ;;; GNU Guix is distributed in the hope that it will be useful, but
  25 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  26 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  27 ;;; GNU General Public License for more details.
  28 ;;;
  29 ;;; You should have received a copy of the GNU General Public License
  30 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  31
  32 (define-module (guix-gc)
  33   #:use-module (guix ui)
  34   #:use-module (guix store)
  35   #:use-module (ice-9 match)
  36   #:use-module (srfi srfi-1)
  37   #:use-module (srfi srfi-26)
  38   #:use-module (srfi srfi-37)
  39   #:export (guix-gc))
  40
  41 \f
  42 ;;;
  43 ;;; Command-line options.
  44 ;;;
  45
  46 (define %default-options
  47   ;; Alist of default option values.
  48   `((action . collect-garbage)))
  49
  50 (define (show-help)
  51   (display (_ "Usage: guix-gc [OPTION]... PATHS...
  52 Invoke the garbage collector.\n"))
  53   (display (_ "
  54   -C, --collect-garbage[=MIN]
  55                          collect at least MIN bytes of garbage"))
  56   (display (_ "
  57   -d, --delete           attempt to delete PATHS"))
  58   (display (_ "
  59       --list-dead        list dead paths"))
  60   (display (_ "
  61       --list-live        list live paths"))
  62   (newline)
  63   (display (_ "
  64   -h, --help             display this help and exit"))
  65   (display (_ "
  66   -V, --version          display version information and exit"))
  67   (newline)
  68   (show-bug-report-information))
  69
  70 (define (size->number str)
  71   "Convert STR, a storage measurement representation such as \"1024\" or
  72 \"1MiB\", to a number of bytes.  Raise an error if STR could not be
  73 interpreted."
  74   (define unit-pos
  75     (string-rindex str char-set:digit))
  76
  77   (define unit
  78     (and unit-pos (substring str (+ 1 unit-pos))))
  79
  80   (let* ((numstr (if unit-pos
  81                      (substring str 0 (+ 1 unit-pos))
  82                      str))
  83          (num    (string->number numstr)))
  84     (if num
  85         (* num
  86            (match unit
  87              ("KiB" (expt 2 10))
  88              ("MiB" (expt 2 20))
  89              ("GiB" (expt 2 30))
  90              ("TiB" (expt 2 40))
  91              ("KB"  (expt 10 3))
  92              ("MB"  (expt 10 6))
  93              ("GB"  (expt 10 9))
  94              ("TB"  (expt 10 12))
  95              (""    1)
  96              (_
  97               (format (current-error-port) (_ "error: unknown unit: ~a~%")
  98                       unit)
  99               (exit 1))))
 100         (begin
 101           (format (current-error-port)
 102                   (_ "error: invalid number: ~a") numstr)
 103           (exit 1)))))
 104
 105 (define %options
 106   ;; Specification of the command-line options.
 107   (list (option '(#\h "help") #f #f
 108                 (lambda args
 109                   (show-help)
 110                   (exit 0)))
 111         (option '(#\V "version") #f #f
 112                 (lambda args
 113                   (show-version-and-exit "guix-gc")))
 114
 115         (option '(#\C "collect-garbage") #f #t
 116                 (lambda (opt name arg result)
 117                   (let ((result (alist-cons 'action 'collect-garbage
 118                                             (alist-delete 'action result))))
 119                    (match arg
 120                      ((? string?)
 121                       (let ((amount (size->number arg)))
 122                         (if arg
 123                             (alist-cons 'min-freed amount result)
 124                             (begin
 125                               (format (current-error-port)
 126                                       (_ "error: invalid amount of storage: ~a~%")
 127                                       arg)
 128                               (exit 1)))))
 129                      (#f result)))))
 130         (option '(#\d "delete") #f #f
 131                 (lambda (opt name arg result)
 132                   (alist-cons 'action 'delete
 133                               (alist-delete 'action result))))
 134         (option '("list-dead") #f #f
 135                 (lambda (opt name arg result)
 136                   (alist-cons 'action 'list-dead
 137                               (alist-delete 'action result))))
 138         (option '("list-live") #f #f
 139                 (lambda (opt name arg result)
 140                   (alist-cons 'action 'list-live
 141                               (alist-delete 'action result))))))
 142
 143 \f
 144 ;;;
 145 ;;; Entry point.
 146 ;;;
 147
 148 (define (guix-gc . args)
 149   (define (parse-options)
 150     ;; Return the alist of option values.
 151     (args-fold args %options
 152                (lambda (opt name arg result)
 153                  (leave (_ "~A: unrecognized option~%") name))
 154                (lambda (arg result)
 155                  (alist-cons 'argument arg result))
 156                %default-options))
 157
 158   (setlocale LC_ALL "")
 159   (textdomain "guix")
 160   (setvbuf (current-output-port) _IOLBF)
 161   (setvbuf (current-error-port) _IOLBF)
 162
 163   (with-error-handling
 164     (let ((opts  (parse-options))
 165           (store (open-connection)))
 166       (case (assoc-ref opts 'action)
 167         ((collect-garbage)
 168          (let ((min-freed (assoc-ref opts 'min-freed)))
 169            (if min-freed
 170                (collect-garbage store min-freed)
 171                (collect-garbage store))))
 172         ((delete)
 173          (let ((paths (filter-map (match-lambda
 174                                    (('argument . arg) arg)
 175                                    (_ #f))
 176                                   opts)))
 177            (delete-paths store paths)))
 178         ((list-dead)
 179          (for-each (cut simple-format #t "~a~%" <>)
 180                    (dead-paths store)))
 181         ((list-live)
 182          (for-each (cut simple-format #t "~a~%" <>)
 183                    (live-paths store)))))))