guix/scripts/size.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017, 2018, 2019 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 scripts)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module (guix combinators)
  25   #:use-module (guix grafts)
  26   #:use-module (guix packages)
  27   #:use-module (guix derivations)
  28   #:use-module (gnu packages)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-9)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-37)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 format)
  37   #:use-module (ice-9 vlist)
  38   #:export (profile?
  39             profile-file
  40             profile-self-size
  41             profile-closure-size
  42             store-profile
  43
  44             guix-size))
  45
  46 ;; Size profile of a store item.
  47 (define-record-type <profile>
  48   (profile file self-size closure-size)
  49   profile?
  50   (file          profile-file)                 ;store item
  51   (self-size     profile-self-size)            ;size in bytes
  52   (closure-size  profile-closure-size))        ;size of dependencies in bytes
  53
  54 (define substitutable-path-info*
  55   (store-lift substitutable-path-info))
  56
  57 (define (file-size item)
  58   "Return the size in bytes of ITEM, resorting to information from substitutes
  59 if ITEM is not in the store."
  60   (mlet %store-monad ((info (query-path-info* item)))
  61     (if info
  62         (return (path-info-nar-size info))
  63         (mlet %store-monad ((info (substitutable-path-info* (list item))))
  64           (match info
  65             ((info)
  66              ;; The nar size is an approximation, but a good one.
  67              (return (substitutable-nar-size info)))
  68             (()
  69              (leave (G_ "no available substitute information for '~a'~%")
  70                     item)))))))
  71
  72 (define profile-closure<?
  73   (match-lambda*
  74     ((($ <profile> name1 self1 total1)
  75       ($ <profile> name2 self2 total2))
  76      (< total1 total2))))
  77
  78 (define profile-self<?
  79   (match-lambda*
  80     ((($ <profile> name1 self1 total1)
  81       ($ <profile> name2 self2 total2))
  82      (< self1 self2))))
  83
  84 (define* (display-profile profile #:optional (port (current-output-port))
  85                           #:key (profile<? profile-closure<?))
  86   "Display PROFILE, a list of PROFILE objects, to PORT.  Sort entries
  87 according to PROFILE<?."
  88   (define MiB (expt 2 20))
  89
  90   (format port "~64a ~8a ~a\n"
  91           (G_ "store item") (G_ "total") (G_ "self"))
  92   (let ((whole (reduce + 0 (map profile-self-size profile))))
  93     (for-each (match-lambda
  94                 (($ <profile> name self total)
  95                  (format port "~64a  ~6,1f  ~6,1f ~5,1f%\n"
  96                          name (/ total MiB) (/ self MiB)
  97                          (* 100. (/ self whole 1.)))))
  98               (sort profile (negate profile<?)))
  99     (format port (G_ "total: ~,1f MiB~%") (/ whole MiB 1.))))
 100
 101 (define display-profile*
 102   (lift display-profile %store-monad))
 103
 104 (define (substitutable-requisites store items)
 105   "Return the list of requisites of ITEMS based on information available in
 106 substitutes."
 107   (let loop ((items  items)
 108              (result '()))
 109     (match items
 110       (()
 111        (delete-duplicates result))
 112       (items
 113        (let ((info (substitutable-path-info store
 114                                             (delete-duplicates items))))
 115          (loop (remove (lambda (item)             ;XXX: complexity
 116                          (member item result))
 117                        (append-map substitutable-references info))
 118                (append (append-map substitutable-references info)
 119                        result)))))))
 120
 121 (define (requisites* items)
 122   "Return as a monadic value the requisites of ITEMS, based either on the
 123 information available in the local store or using information about
 124 substitutes."
 125   (lambda (store)
 126     (let-values (((local missing)
 127                   (partition (cut valid-path? store <>) items)))
 128       (values (delete-duplicates
 129                (append (requisites store local)
 130                        (substitutable-requisites store missing)))
 131               store))))
 132
 133 (define (store-profile items)
 134   "Return as a monadic value a list of <profile> objects representing the
 135 profile of ITEMS and their requisites."
 136   (mlet* %store-monad ((refs  (>>= (requisites* items)
 137                                    (lambda (refs)
 138                                      (return (delete-duplicates
 139                                               (append items refs))))))
 140                        (sizes (mapm %store-monad
 141                                     (lambda (item)
 142                                       (>>= (file-size item)
 143                                            (lambda (size)
 144                                              (return (cons item size)))))
 145                                     refs)))
 146     (define size-table
 147       (fold (lambda (pair result)
 148               (match pair
 149                 ((item . size)
 150                  (vhash-cons item size result))))
 151             vlist-null sizes))
 152
 153     (define (dependency-size item)
 154       (mlet %store-monad ((deps (requisites* (list item))))
 155         (foldm %store-monad
 156                (lambda (item total)
 157                  (return (+ (match (vhash-assoc item size-table)
 158                               ((_ . size) size))
 159                             total)))
 160                0
 161                (delete-duplicates (cons item deps)))))
 162
 163     (mapm %store-monad
 164           (match-lambda
 165             ((item . size)
 166              (mlet %store-monad ((dependencies (dependency-size item)))
 167                (return (profile item size dependencies)))))
 168           sizes)))
 169
 170 (define* (ensure-store-item spec-or-item)
 171   "Return a store file name.  If SPEC-OR-ITEM is a store file name, return it
 172 as is.  Otherwise, assume SPEC-OR-ITEM is a package output specification such
 173 as \"guile:debug\" or \"gcc-4.8\" and return its store file name."
 174   (with-monad %store-monad
 175     (if (store-path? spec-or-item)
 176         (return spec-or-item)
 177         (let-values (((package output)
 178                       (specification->package+output spec-or-item)))
 179           (mlet %store-monad ((drv (package->derivation package)))
 180             ;; Note: we don't try building DRV like 'guix archive' does
 181             ;; because we don't have to since we can instead rely on
 182             ;; substitute meta-data.
 183             (return (derivation->output-path drv output)))))))
 184
 185 \f
 186 ;;;
 187 ;;; Charts.
 188 ;;;
 189
 190 ;; Autoload Guile-Charting.
 191 ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
 192 ;; See <http://bugs.gnu.org/12202>.
 193 (module-autoload! (current-module)
 194                   '(charting) '(make-page-map))
 195
 196 (define (profile->page-map profiles file)
 197   "Write a 'page map' chart of PROFILES, a list of <profile> objects, to FILE,
 198 the name of a PNG file."
 199   (define (strip name)
 200     (string-drop name (+ (string-length (%store-prefix)) 28)))
 201
 202   (define data
 203     (fold2 (lambda (profile result offset)
 204              (match profile
 205                (($ <profile> name self)
 206                 (let ((self (inexact->exact
 207                              (round (/ self (expt 2. 10))))))
 208                   (values `((,(strip name) ,offset . ,self)
 209                             ,@result)
 210                           (+ offset self))))))
 211            '()
 212            0
 213            (sort profiles
 214                  (match-lambda*
 215                    ((($ <profile> name1 self1 total1)
 216                      ($ <profile> name2 self2 total2))
 217                     (> total1 total2))))))
 218
 219   ;; TRANSLATORS: This is the title of a graph, meaning that the graph
 220   ;; represents a profile of the store (the "store" being the place where
 221   ;; packages are stored.)
 222   (make-page-map (G_ "store profile") data
 223                  #:write-to-png file))
 224
 225 \f
 226 ;;;
 227 ;;; Options.
 228 ;;;
 229
 230 (define (show-help)
 231   (display (G_ "Usage: guix size [OPTION]... PACKAGE
 232 Report the size of PACKAGE and its dependencies.\n"))
 233   (display (G_ "
 234       --substitute-urls=URLS
 235                          fetch substitute from URLS if they are authorized"))
 236   (display (G_ "
 237   -s, --system=SYSTEM    consider packages for SYSTEM--e.g., \"i686-linux\""))
 238   ;; TRANSLATORS: "closure" and "self" must not be translated.
 239   (display (G_ "
 240       --sort=KEY         sort according to KEY--\"closure\" or \"self\""))
 241   (display (G_ "
 242   -m, --map-file=FILE    write to FILE a graphical map of disk usage"))
 243   (newline)
 244   (display (G_ "
 245   -h, --help             display this help and exit"))
 246   (display (G_ "
 247   -V, --version          display version information and exit"))
 248   (newline)
 249   (show-bug-report-information))
 250
 251 (define %options
 252   ;; Specifications of the command-line options.
 253   (list (option '(#\s "system") #t #f
 254                 (lambda (opt name arg result)
 255                   (alist-cons 'system arg
 256                               (alist-delete 'system result eq?))))
 257         (option '("substitute-urls") #t #f
 258                 (lambda (opt name arg result . rest)
 259                   (apply values
 260                          (alist-cons 'substitute-urls
 261                                      (string-tokenize arg)
 262                                      (alist-delete 'substitute-urls result))
 263                          rest)))
 264         (option '("sort") #t #f
 265                 (lambda (opt name arg result . rest)
 266                   (match arg
 267                     ("closure"
 268                      (alist-cons 'profile<? profile-closure<? result))
 269                     ("self"
 270                      (alist-cons 'profile<? profile-self<? result))
 271                     (_
 272                      (leave (G_ "~a: invalid sorting key~%") arg)))))
 273         (option '(#\m "map-file") #t #f
 274                 (lambda (opt name arg result)
 275                   (alist-cons 'map-file arg result)))
 276         (option '(#\h "help") #f #f
 277                 (lambda args
 278                   (show-help)
 279                   (exit 0)))
 280         (option '(#\V "version") #f #f
 281                 (lambda args
 282                   (show-version-and-exit "guix size")))))
 283
 284 (define %default-options
 285   `((system . ,(%current-system))
 286     (profile<? . ,profile-self<?)))
 287
 288 \f
 289 ;;;
 290 ;;; Entry point.
 291 ;;;
 292
 293 (define (guix-size . args)
 294   (with-error-handling
 295     (let* ((opts     (parse-command-line args %options (list %default-options)
 296                                          #:build-options? #f))
 297            (files    (filter-map (match-lambda
 298                                    (('argument . file) file)
 299                                    (_ #f))
 300                                  opts))
 301            (profile<? (assoc-ref opts 'profile<?))
 302            (map-file (assoc-ref opts 'map-file))
 303            (system   (assoc-ref opts 'system))
 304            (urls     (assoc-ref opts 'substitute-urls)))
 305       (match files
 306         (()
 307          (leave (G_ "missing store item argument\n")))
 308         ((files ..1)
 309          (leave-on-EPIPE
 310           ;; Turn off grafts because (1) substitute servers do not serve grafted
 311           ;; packages, and (2) they do not make any difference on the
 312           ;; resulting size.
 313           (parameterize ((%graft? #f))
 314             (with-store store
 315               (set-build-options store
 316                                  #:use-substitutes? #t
 317                                  #:substitute-urls urls)
 318
 319               (run-with-store store
 320                 (mlet* %store-monad ((items   (mapm %store-monad
 321                                                     ensure-store-item files))
 322                                      (profile (store-profile items)))
 323                   (if map-file
 324                       (begin
 325                         (profile->page-map profile map-file)
 326                         (return #t))
 327                       (display-profile* profile (current-output-port)
 328                                         #:profile<? profile<?)))
 329                 #:system system)))))))))