[jackhill/guix/guix.git] / guix / scripts / size.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts size)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix combinators)
  #:use-module (guix grafts)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (gnu packages)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (profile?
            profile-file
            profile-self-size
            profile-closure-size
            store-profile

            guix-size))

;; Size profile of a store item.
(define-record-type <profile>
  (profile file self-size closure-size)
  profile?
  (file          profile-file)                 ;store item
  (self-size     profile-self-size)            ;size in bytes
  (closure-size  profile-closure-size))        ;size of dependencies in bytes

(define substitutable-path-info*
  (store-lift substitutable-path-info))

(define (file-size item)
  "Return the size in bytes of ITEM, resorting to information from substitutes
if ITEM is not in the store."
  (mlet %store-monad ((info (query-path-info* item)))
    (if info
        (return (path-info-nar-size info))
        (mlet %store-monad ((info (substitutable-path-info* (list item))))
          (match info
            ((info)
             ;; The nar size is an approximation, but a good one.
             (return (substitutable-nar-size info)))
            (()
             (leave (G_ "no available substitute information for '~a'~%")
                    item)))))))

(define profile-closure<?
  (match-lambda*
    ((($ <profile> name1 self1 total1)
      ($ <profile> name2 self2 total2))
     (< total1 total2))))

(define profile-self<?
  (match-lambda*
    ((($ <profile> name1 self1 total1)
      ($ <profile> name2 self2 total2))
     (< self1 self2))))

(define* (display-profile profile #:optional (port (current-output-port))
                          #:key (profile<? profile-closure<?))
  "Display PROFILE, a list of PROFILE objects, to PORT.  Sort entries
according to PROFILE<?."
  (define MiB (expt 2 20))

  (format port "~64a ~8a ~a\n"
          (G_ "store item") (G_ "total") (G_ "self"))
  (let ((whole (reduce + 0 (map profile-self-size profile))))
    (for-each (match-lambda
                (($ <profile> name self total)
                 (format port "~64a  ~6,1f  ~6,1f ~5,1f%\n"
                         name (/ total MiB) (/ self MiB)
                         (* 100. (/ self whole 1.)))))
              (sort profile (negate profile<?)))
    (format port (G_ "total: ~,1f MiB~%") (/ whole MiB 1.))))

(define display-profile*
  (lift display-profile %store-monad))

(define (substitutable-requisites store items)
  "Return the list of requisites of ITEMS based on information available in
substitutes."
  (let loop ((items  items)
             (result '()))
    (match items
      (()
       (delete-duplicates result))
      (items
       (let ((info (substitutable-path-info store
                                            (delete-duplicates items))))
         (loop (remove (lambda (item)             ;XXX: complexity
                         (member item result))
                       (append-map substitutable-references info))
               (append (append-map substitutable-references info)
                       result)))))))

(define (requisites* items)
  "Return as a monadic value the requisites of ITEMS, based either on the
information available in the local store or using information about
substitutes."
  (lambda (store)
    (let-values (((local missing)
                  (partition (cut valid-path? store <>) items)))
      (values (delete-duplicates
               (append (requisites store local)
                       (substitutable-requisites store missing)))
              store))))

(define (store-profile items)
  "Return as a monadic value a list of <profile> objects representing the
profile of ITEMS and their requisites."
  (mlet* %store-monad ((refs  (>>= (requisites* items)
                                   (lambda (refs)
                                     (return (delete-duplicates
                                              (append items refs))))))
                       (sizes (mapm %store-monad
                                    (lambda (item)
                                      (>>= (file-size item)
                                           (lambda (size)
                                             (return (cons item size)))))
                                    refs)))
    (define (dependency-size item)
      (mlet %store-monad ((deps (requisites* (list item))))
        (foldm %store-monad
               (lambda (item total)
                 (return (+ (assoc-ref sizes item) total)))
               0
               (delete-duplicates (cons item deps)))))

    (mapm %store-monad
          (match-lambda
            ((item . size)
             (mlet %store-monad ((dependencies (dependency-size item)))
               (return (profile item size dependencies)))))
          sizes)))

(define* (ensure-store-item spec-or-item)
  "Return a store file name.  If SPEC-OR-ITEM is a store file name, return it
as is.  Otherwise, assume SPEC-OR-ITEM is a package output specification such
as \"guile:debug\" or \"gcc-4.8\" and return its store file name."
  (with-monad %store-monad
    (if (store-path? spec-or-item)
        (return spec-or-item)
        (let-values (((package output)
                      (specification->package+output spec-or-item)))
          (mlet %store-monad ((drv (package->derivation package)))
            ;; Note: we don't try building DRV like 'guix archive' does
            ;; because we don't have to since we can instead rely on
            ;; substitute meta-data.
            (return (derivation->output-path drv output)))))))

\f
;;;
;;; Charts.
;;;

;; Autoload Guile-Charting.
;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
;; See <http://bugs.gnu.org/12202>.
(module-autoload! (current-module)
                  '(charting) '(make-page-map))

(define (profile->page-map profiles file)
  "Write a 'page map' chart of PROFILES, a list of <profile> objects, to FILE,
the name of a PNG file."
  (define (strip name)
    (string-drop name (+ (string-length (%store-prefix)) 28)))

  (define data
    (fold2 (lambda (profile result offset)
             (match profile
               (($ <profile> name self)
                (let ((self (inexact->exact
                             (round (/ self (expt 2. 10))))))
                  (values `((,(strip name) ,offset . ,self)
                            ,@result)
                          (+ offset self))))))
           '()
           0
           (sort profiles
                 (match-lambda*
                   ((($ <profile> name1 self1 total1)
                     ($ <profile> name2 self2 total2))
                    (> total1 total2))))))

  ;; TRANSLATORS: This is the title of a graph, meaning that the graph
  ;; represents a profile of the store (the "store" being the place where
  ;; packages are stored.)
  (make-page-map (G_ "store profile") data
                 #:write-to-png file))

\f
;;;
;;; Options.
;;;

(define (show-help)
  (display (G_ "Usage: guix size [OPTION]... PACKAGE
Report the size of PACKAGE and its dependencies.\n"))
  (display (G_ "
      --substitute-urls=URLS
                         fetch substitute from URLS if they are authorized"))
  (display (G_ "
  -s, --system=SYSTEM    consider packages for SYSTEM--e.g., \"i686-linux\""))
  ;; TRANSLATORS: "closure" and "self" must not be translated.
  (display (G_ "
      --sort=KEY         sort according to KEY--\"closure\" or \"self\""))
  (display (G_ "
  -m, --map-file=FILE    write to FILE a graphical map of disk usage"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\s "system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'system arg
                              (alist-delete 'system result eq?))))
        (option '("substitute-urls") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitute-urls
                                     (string-tokenize arg)
                                     (alist-delete 'substitute-urls result))
                         rest)))
        (option '("sort") #t #f
                (lambda (opt name arg result . rest)
                  (match arg
                    ("closure"
                     (alist-cons 'profile<? profile-closure<? result))
                    ("self"
                     (alist-cons 'profile<? profile-self<? result))
                    (_
                     (leave (G_ "~a: invalid sorting key~%") arg)))))
        (option '(#\m "map-file") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'map-file arg result)))
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix size")))))

(define %default-options
  `((system . ,(%current-system))
    (profile<? . ,profile-self<?)))

\f
;;;
;;; Entry point.
;;;

(define (guix-size . args)
  (with-error-handling
    (let* ((opts     (parse-command-line args %options (list %default-options)
                                         #:build-options? #f))
           (files    (filter-map (match-lambda
                                   (('argument . file) file)
                                   (_ #f))
                                 opts))
           (profile<? (assoc-ref opts 'profile<?))
           (map-file (assoc-ref opts 'map-file))
           (system   (assoc-ref opts 'system))
           (urls     (assoc-ref opts 'substitute-urls)))
      (match files
        (()
         (leave (G_ "missing store item argument\n")))
        ((files ..1)
         (leave-on-EPIPE
          ;; Turn off grafts because (1) substitute servers do not serve grafted
          ;; packages, and (2) they do not make any difference on the
          ;; resulting size.
          (parameterize ((%graft? #f))
            (with-store store
              (set-build-options store
                                 #:use-substitutes? #t
                                 #:substitute-urls urls)

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