guix/scripts/size.scm

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