You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

178 lines
6.3 KiB

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