guix/scripts/size.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 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 size)
  20   #:use-module (guix ui)
  21   #:use-module (guix store)
  22   #:use-module (guix monads)
  23   #:use-module (guix utils)
  24   #:use-module (guix packages)
  25   #:use-module (guix derivations)
  26   #:use-module (gnu packages)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-9)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-37)
  32   #:use-module (ice-9 ftw)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 format)
  35   #:export (profile?
  36             profile-file
  37             profile-self-size
  38             profile-closure-size
  39             store-profile
  40
  41             guix-size))
  42
  43 ;; Size profile of a store item.
  44 (define-record-type <profile>
  45   (profile file self-size closure-size)
  46   profile?
  47   (file          profile-file)                 ;store item
  48   (self-size     profile-self-size)            ;size in bytes
  49   (closure-size  profile-closure-size))        ;size of dependencies in bytes
  50
  51 (define (file-size file)
  52   "Return the size of bytes of FILE, entering it if FILE is a directory."
  53   (file-system-fold (const #t)
  54                     (lambda (file stat result)    ;leaf
  55                       (+ (stat:size stat) result))
  56                     (lambda (directory stat result) ;down
  57                       (+ (stat:size stat) result))
  58                     (lambda (directory stat result) ;up
  59                       result)
  60                     (lambda (file stat result)    ;skip
  61                       result)
  62                     (lambda (file stat errno result)
  63                       (format (current-error-port)
  64                               "file-size: ~a: ~a~%" file
  65                               (strerror errno))
  66                       result)
  67                     0
  68                     file
  69                     lstat))
  70
  71 (define substitutable-path-info*
  72   (store-lift substitutable-path-info))
  73
  74 (define (store-item-exists? item)
  75   "Return #t if ITEM is in the store, and protect it from GC.  Otherwise
  76 return #f."
  77   (lambda (store)
  78     (add-temp-root store item)
  79     (values (valid-path? store item) store)))
  80
  81 (define (file-size* item)
  82   "Like 'file-size', but resort to information from substitutes if ITEM is not
  83 in the store."
  84   (mlet %store-monad ((exists? (store-item-exists? item)))
  85     (if exists?
  86         (return (file-size item))
  87         (mlet %store-monad ((info (substitutable-path-info* (list item))))
  88           (match info
  89             ((info)
  90              ;; The nar size is an approximation, but a good one.
  91              (return (substitutable-nar-size info)))
  92             (()
  93              (leave (_ "no available substitute information for '~a'~%")
  94                     item)))))))
  95
  96 (define* (display-profile profile #:optional (port (current-output-port)))
  97   "Display PROFILE, a list of PROFILE objects, to PORT."
  98   (define MiB (expt 2 20))
  99
 100   (format port "~64a ~8a ~a\n"
 101           (_ "store item") (_ "total") (_ "self"))
 102   (let ((whole (reduce + 0 (map profile-self-size profile))))
 103     (for-each (match-lambda
 104                 (($ <profile> name self total)
 105                  (format port "~64a  ~6,1f  ~6,1f ~5,1f%\n"
 106                          name (/ total MiB) (/ self MiB)
 107                          (* 100. (/ self whole 1.)))))
 108               (sort profile
 109                     (match-lambda*
 110                       ((($ <profile> _ _ total1) ($ <profile> _ _ total2))
 111                        (> total1 total2)))))))
 112
 113 (define display-profile*
 114   (lift display-profile %store-monad))
 115
 116 (define (substitutable-requisites store item)
 117   "Return the list of requisites of ITEM based on information available in
 118 substitutes."
 119   (let loop ((items  (list item))
 120              (result '()))
 121     (match items
 122       (()
 123        (delete-duplicates result))
 124       (items
 125        (let ((info (substitutable-path-info store
 126                                             (delete-duplicates items))))
 127          (loop (remove (lambda (item)             ;XXX: complexity
 128                          (member item result))
 129                        (append-map substitutable-references info))
 130                (append (append-map substitutable-references info)
 131                        result)))))))
 132
 133 (define (requisites* item)
 134   "Return as a monadic value the requisites of ITEMS, based either on the
 135 information available in the local store or using information about
 136 substitutes."
 137   (lambda (store)
 138     (guard (c ((nix-protocol-error? c)
 139                (values (substitutable-requisites store item)
 140                        store)))
 141       (values (requisites store item) store))))
 142
 143 (define (store-profile item)
 144   "Return as a monadic value a list of <profile> objects representing the
 145 profile of ITEM and its requisites."
 146   (mlet* %store-monad ((refs  (>>= (requisites* item)
 147                                    (lambda (refs)
 148                                      (return (delete-duplicates
 149                                               (cons item refs))))))
 150                        (sizes (mapm %store-monad
 151                                     (lambda (item)
 152                                       (>>= (file-size* item)
 153                                            (lambda (size)
 154                                              (return (cons item size)))))
 155                                     refs)))
 156     (define (dependency-size item)
 157       (mlet %store-monad ((deps (requisites* item)))
 158         (foldm %store-monad
 159                (lambda (item total)
 160                  (return (+ (assoc-ref sizes item) total)))
 161                0
 162                (delete-duplicates (cons item deps)))))
 163
 164     (mapm %store-monad
 165           (match-lambda
 166             ((item . size)
 167              (mlet %store-monad ((dependencies (dependency-size item)))
 168                (return (profile item size dependencies)))))
 169           sizes)))
 170
 171 (define* (ensure-store-item spec-or-item
 172                             #:key dry-run?)
 173   "Return a store file name.  If SPEC-OR-ITEM is a store file name, return it
 174 as is.  Otherwise, assume SPEC-OR-ITEM is a package output specification such
 175 as \"guile:debug\" or \"gcc-4.8\" and return its store file name."
 176   (with-monad %store-monad
 177     (if (store-path? spec-or-item)
 178         (return spec-or-item)
 179         (let-values (((package output)
 180                       (specification->package+output spec-or-item)))
 181           (mlet %store-monad ((drv (package->derivation package)))
 182             ;; Note: we don't try building DRV like 'guix archive' does
 183             ;; because we don't have to since we can instead rely on
 184             ;; substitute meta-data.
 185             (return (derivation->output-path drv output)))))))
 186
 187 \f
 188 ;;;
 189 ;;; Options.
 190 ;;;
 191
 192 (define (show-help)
 193   (display (_ "Usage: guix size [OPTION]... PACKAGE
 194 Report the size of PACKAGE and its dependencies.\n"))
 195   (display (_ "
 196   -s, --system=SYSTEM    consider packages for SYSTEM--e.g., \"i686-linux\""))
 197   (newline)
 198   (display (_ "
 199   -h, --help             display this help and exit"))
 200   (display (_ "
 201   -V, --version          display version information and exit"))
 202   (newline)
 203   (show-bug-report-information))
 204
 205 (define %options
 206   ;; Specifications of the command-line options.
 207   (list (option '(#\s "system") #t #f
 208                 (lambda (opt name arg result)
 209                   (alist-cons 'system arg
 210                               (alist-delete 'system result eq?))))
 211         (option '(#\h "help") #f #f
 212                 (lambda args
 213                   (show-help)
 214                   (exit 0)))
 215         (option '(#\V "version") #f #f
 216                 (lambda args
 217                   (show-version-and-exit "guix size")))))
 218
 219 (define %default-options
 220   `((system . ,(%current-system))))
 221
 222 \f
 223 ;;;
 224 ;;; Entry point.
 225 ;;;
 226
 227 (define (guix-size . args)
 228   (with-error-handling
 229     (let* ((opts     (parse-command-line args %options (list %default-options)))
 230            (files    (filter-map (match-lambda
 231                                    (('argument . file) file)
 232                                    (_ #f))
 233                                  opts))
 234            (system   (assoc-ref opts 'system))
 235            (dry-run? (assoc-ref opts 'dry-run?)))
 236       (match files
 237         (()
 238          (leave (_ "missing store item argument\n")))
 239         ((file)
 240          (with-store store
 241            (run-with-store store
 242              (mlet* %store-monad ((item    (ensure-store-item file))
 243                                   (profile (store-profile item)))
 244                (display-profile* profile))
 245              #:system system)))
 246         ((files ...)
 247          (leave (_ "too many arguments\n")))))))