guix/scripts/graph.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts graph)
  21   #:use-module (guix ui)
  22   #:use-module (guix graph)
  23   #:use-module (guix grafts)
  24   #:use-module (guix scripts)
  25   #:use-module (guix packages)
  26   #:use-module (guix monads)
  27   #:use-module (guix store)
  28   #:use-module (guix gexp)
  29   #:use-module (guix derivations)
  30   #:use-module (guix memoization)
  31   #:use-module (guix modules)
  32   #:use-module ((guix build-system gnu) #:select (standard-packages))
  33   #:use-module (gnu packages)
  34   #:use-module (guix sets)
  35   #:use-module ((guix utils) #:select (location-file))
  36   #:use-module ((guix scripts build)
  37                 #:select (show-transformation-options-help
  38                           options->transformation
  39                           %standard-build-options
  40                           %transformation-options))
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-26)
  43   #:use-module (srfi srfi-34)
  44   #:use-module (srfi srfi-35)
  45   #:use-module (srfi srfi-37)
  46   #:use-module (ice-9 match)
  47   #:export (%package-node-type
  48             %reverse-package-node-type
  49             %bag-node-type
  50             %bag-with-origins-node-type
  51             %bag-emerged-node-type
  52             %reverse-bag-node-type
  53             %derivation-node-type
  54             %reference-node-type
  55             %referrer-node-type
  56             %module-node-type
  57             %node-types
  58
  59             guix-graph))
  60
  61 \f
  62 ;;;
  63 ;;; Package DAG.
  64 ;;;
  65
  66 (define (node-full-name thing)
  67   "Return a human-readable name to denote THING, a package, origin, or file
  68 name."
  69   (cond ((package? thing)
  70          (package-full-name thing))
  71         ((origin? thing)
  72          (origin-actual-file-name thing))
  73         ((string? thing)                          ;file name
  74          (or (basename thing)
  75              (error "basename" thing)))
  76         (else
  77          (number->string (object-address thing) 16))))
  78
  79 (define (package-node-edges package)
  80   "Return the list of dependencies of PACKAGE."
  81   (match (package-direct-inputs package)
  82     (((labels packages . outputs) ...)
  83      ;; Filter out origins and other non-package dependencies.
  84      (filter package? packages))))
  85
  86 (define assert-package
  87   (match-lambda
  88     ((? package? package)
  89      package)
  90     (x
  91      (raise
  92       (condition
  93        (&message
  94         (message (format #f (G_ "~a: invalid argument (package name expected)")
  95                          x))))))))
  96
  97 (define nodes-from-package
  98   ;; The default conversion method.
  99   (lift1 (compose list assert-package) %store-monad))
 100
 101 (define %package-node-type
 102   ;; Type for the traversal of package nodes.
 103   (node-type
 104    (name "package")
 105    (description "the DAG of packages, excluding implicit inputs")
 106    (convert nodes-from-package)
 107
 108    ;; We use package addresses as unique identifiers.  This generally works
 109    ;; well, but for generated package objects, we could end up with two
 110    ;; packages that are not 'eq?', yet map to the same derivation (XXX).
 111    (identifier (lift1 object-address %store-monad))
 112    (label node-full-name)
 113    (edges (lift1 package-node-edges %store-monad))))
 114
 115 \f
 116 ;;;
 117 ;;; Reverse package DAG.
 118 ;;;
 119
 120 (define (all-packages)            ;XXX: duplicated from (guix scripts refresh)
 121   "Return the list of all the distro's packages."
 122   (fold-packages (lambda (package result)
 123                    ;; Ignore deprecated packages.
 124                    (if (package-superseded package)
 125                        result
 126                        (cons package result)))
 127                  '()
 128                  #:select? (const #t)))           ;include hidden packages
 129
 130 (define %reverse-package-node-type
 131   ;; For this node type we first need to compute the list of packages and the
 132   ;; list of back-edges.  Since we want to do it only once, we use the
 133   ;; promises below.
 134   (let* ((packages   (delay (all-packages)))
 135          (back-edges (delay (run-with-store #f    ;store not actually needed
 136                               (node-back-edges %package-node-type
 137                                                (force packages))))))
 138     (node-type
 139      (inherit %package-node-type)
 140      (name "reverse-package")
 141      (description "the reverse DAG of packages")
 142      (edges (lift1 (force back-edges) %store-monad)))))
 143
 144 \f
 145 ;;;
 146 ;;; Package DAG using bags.
 147 ;;;
 148
 149 (define (bag-node-identifier thing)
 150   "Return a unique identifier for THING, which may be a package, origin, or a
 151 file name."
 152   ;; If THING is a file name (a string), we just return it; if it's a package
 153   ;; or origin, we return its address.  That gives us the object graph, but
 154   ;; that may differ from the derivation graph (for instance,
 155   ;; 'package-with-bootstrap-guile' generates fresh package objects, and
 156   ;; several packages that are not 'eq?' may actually map to the same
 157   ;; derivation.)  Thus, we lower THING and use its derivation file name as a
 158   ;; unique identifier.
 159   (with-monad %store-monad
 160     (if (string? thing)
 161         (return thing)
 162         (mlet %store-monad ((low (lower-object thing)))
 163           (return (if (derivation? low)
 164                       (derivation-file-name low)
 165                       low))))))
 166
 167 (define (bag-node-edges thing)
 168   "Return the list of dependencies of THING, a package or origin.
 169 Dependencies may include packages, origin, and file names."
 170   (cond ((package? thing)
 171          (match (bag-direct-inputs (package->bag thing))
 172            (((labels things . outputs) ...)
 173             things)))
 174         ((origin? thing)
 175          (cons (or (origin-patch-guile thing) (default-guile))
 176                (if (or (pair? (origin-patches thing))
 177                        (origin-snippet thing))
 178                    (match (origin-patch-inputs thing)
 179                      (#f '())
 180                      (((labels dependencies _ ...) ...)
 181                       (delete-duplicates dependencies eq?)))
 182                    '())))
 183         (else
 184          '())))
 185
 186 (define %bag-node-type
 187   ;; Type for the traversal of package nodes via the "bag" representation,
 188   ;; which includes implicit inputs.
 189   (node-type
 190    (name "bag")
 191    (description "the DAG of packages, including implicit inputs")
 192    (convert nodes-from-package)
 193    (identifier bag-node-identifier)
 194    (label node-full-name)
 195    (edges (lift1 (compose (cut filter package? <>) bag-node-edges)
 196                  %store-monad))))
 197
 198 (define %bag-with-origins-node-type
 199   (node-type
 200    (name "bag-with-origins")
 201    (description "the DAG of packages and origins, including implicit inputs")
 202    (convert nodes-from-package)
 203    (identifier bag-node-identifier)
 204    (label node-full-name)
 205    (edges (lift1 (lambda (thing)
 206                    (filter (match-lambda
 207                              ((? package?) #t)
 208                              ((? origin?)  #t)
 209                              (_            #f))
 210                            (bag-node-edges thing)))
 211                  %store-monad))))
 212
 213 (define standard-package-set
 214   (mlambda ()
 215     "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
 216     (match (standard-packages)
 217       (((labels packages . output) ...)
 218        (list->setq packages)))))
 219
 220 (define (bag-node-edges-sans-bootstrap thing)
 221   "Like 'bag-node-edges', but pretend that the standard packages of
 222 GNU-BUILD-SYSTEM have zero dependencies."
 223   (if (set-contains? (standard-package-set) thing)
 224       '()
 225       (bag-node-edges thing)))
 226
 227 (define %bag-emerged-node-type
 228   ;; Like %BAG-NODE-TYPE, but without the bootstrap subset of the DAG.
 229   (node-type
 230    (name "bag-emerged")
 231    (description "same as 'bag', but without the bootstrap nodes")
 232    (convert nodes-from-package)
 233    (identifier bag-node-identifier)
 234    (label node-full-name)
 235    (edges (lift1 (compose (cut filter package? <>)
 236                           bag-node-edges-sans-bootstrap)
 237                  %store-monad))))
 238
 239 (define %reverse-bag-node-type
 240   ;; Type for the reverse traversal of package nodes via the "bag"
 241   ;; representation, which includes implicit inputs.
 242   (let* ((packages   (delay (package-closure (all-packages))))
 243          (back-edges (delay (run-with-store #f    ;store not actually needed
 244                               (node-back-edges %bag-node-type
 245                                                (force packages))))))
 246     (node-type
 247      (name "reverse-bag")
 248      (description "the reverse DAG of packages, including implicit inputs")
 249      (convert nodes-from-package)
 250      (identifier bag-node-identifier)
 251      (label node-full-name)
 252      (edges (lift1 (force back-edges) %store-monad)))))
 253
 254 \f
 255 ;;;
 256 ;;; Derivation DAG.
 257 ;;;
 258
 259 (define (derivation-dependencies obj)
 260   "Return the <derivation> objects and store items corresponding to the
 261 dependencies of OBJ, a <derivation> or store item."
 262   (if (derivation? obj)
 263       (append (map derivation-input-derivation (derivation-inputs obj))
 264               (derivation-sources obj))
 265       '()))
 266
 267 (define (derivation-node-identifier node)
 268   "Return a unique identifier for NODE, which may be either a <derivation> or
 269 a plain store file."
 270   (if (derivation? node)
 271       (derivation-file-name node)
 272       node))
 273
 274 (define (derivation-node-label node)
 275   "Return a label for NODE, a <derivation> object or plain store item."
 276   (store-path-package-name (match node
 277                              ((? derivation? drv)
 278                               (derivation-file-name drv))
 279                              ((? string? file)
 280                               file))))
 281
 282 (define %derivation-node-type
 283   ;; DAG of derivations.  Very accurate, very detailed, but usually too much
 284   ;; detailed.
 285   (node-type
 286    (name "derivation")
 287    (description "the DAG of derivations")
 288    (convert (match-lambda
 289               ((? package? package)
 290                (with-monad %store-monad
 291                  (>>= (package->derivation package)
 292                       (lift1 list %store-monad))))
 293               ((? derivation-path? item)
 294                (mbegin %store-monad
 295                  ((store-lift add-temp-root) item)
 296                  (return (list (read-derivation-from-file item)))))
 297               (x
 298                (raise
 299                 (condition (&message (message "unsupported argument for \
 300 derivation graph")))))))
 301    (identifier (lift1 derivation-node-identifier %store-monad))
 302    (label derivation-node-label)
 303    (edges (lift1 derivation-dependencies %store-monad))))
 304
 305 \f
 306 ;;;
 307 ;;; DAG of residual references (aka. run-time dependencies).
 308 ;;;
 309
 310 (define ensure-store-items
 311   ;; Return a list of store items as a monadic value based on the given
 312   ;; argument, which may be a store item or a package.
 313   (match-lambda
 314     ((? package? package)
 315      ;; Return the output file names of PACKAGE.
 316      (mlet %store-monad ((drv (package->derivation package)))
 317        (return (match (derivation->output-paths drv)
 318                  (((_ . file-names) ...)
 319                   file-names)))))
 320     ((? store-path? item)
 321      (with-monad %store-monad
 322        (return (list item))))
 323     (x
 324      (raise
 325       (condition (&message (message "unsupported argument for \
 326 this type of graph")))))))
 327
 328 (define (references* item)
 329   "Return as a monadic value the references of ITEM, based either on the
 330 information available in the local store or using information about
 331 substitutes."
 332   (lambda (store)
 333     (guard (c ((store-protocol-error? c)
 334                (match (substitutable-path-info store (list item))
 335                  ((info)
 336                   (values (substitutable-references info) store))
 337                  (()
 338                   (leave (G_ "references for '~a' are not known~%")
 339                          item)))))
 340       (values (references store item) store))))
 341
 342 (define %reference-node-type
 343   (node-type
 344    (name "references")
 345    (description "the DAG of run-time dependencies (store references)")
 346    (convert ensure-store-items)
 347    (identifier (lift1 identity %store-monad))
 348    (label store-path-package-name)
 349    (edges references*)))
 350
 351 (define non-derivation-referrers
 352   (let ((referrers (store-lift referrers)))
 353     (lambda (item)
 354       "Return the referrers of ITEM, except '.drv' files."
 355       (mlet %store-monad ((items (referrers item)))
 356         (return (remove derivation-path? items))))))
 357
 358 (define %referrer-node-type
 359   (node-type
 360    (name "referrers")
 361    (description "the DAG of referrers in the store")
 362    (convert ensure-store-items)
 363    (identifier (lift1 identity %store-monad))
 364    (label store-path-package-name)
 365    (edges non-derivation-referrers)))
 366
 367 \f
 368 ;;;
 369 ;;; Scheme modules.
 370 ;;;
 371
 372 (define (module-from-package package)
 373   (file-name->module-name (location-file (package-location package))))
 374
 375 (define (source-module-dependencies* module)
 376   "Like 'source-module-dependencies' but filter out modules that are not
 377 package modules, while attempting to retain user package modules."
 378   (remove (match-lambda
 379             (('guix _ ...) #t)
 380             (('system _ ...) #t)
 381             (('language _ ...) #t)
 382             (('ice-9 _ ...) #t)
 383             (('srfi _ ...) #t)
 384             (_ #f))
 385           (source-module-dependencies module)))
 386
 387 (define %module-node-type
 388   ;; Show the graph of package modules.
 389   (node-type
 390    (name "module")
 391    (description "the graph of package modules")
 392    (convert (lift1 (compose list module-from-package) %store-monad))
 393    (identifier (lift1 identity %store-monad))
 394    (label object->string)
 395    (edges (lift1 source-module-dependencies* %store-monad))))
 396
 397 \f
 398 ;;;
 399 ;;; List of node types.
 400 ;;;
 401
 402 (define %node-types
 403   ;; List of all the node types.
 404   (list %package-node-type
 405         %reverse-package-node-type
 406         %bag-node-type
 407         %bag-with-origins-node-type
 408         %bag-emerged-node-type
 409         %reverse-bag-node-type
 410         %derivation-node-type
 411         %reference-node-type
 412         %referrer-node-type
 413         %module-node-type))
 414
 415 (define (lookup-node-type name)
 416   "Return the node type called NAME.  Raise an error if it is not found."
 417   (or (find (lambda (type)
 418               (string=? (node-type-name type) name))
 419             %node-types)
 420       (leave (G_ "~a: unknown node type~%") name)))
 421
 422 (define (lookup-backend name)
 423   "Return the graph backend called NAME.  Raise an error if it is not found."
 424   (or (find (lambda (backend)
 425               (string=? (graph-backend-name backend) name))
 426             %graph-backends)
 427       (leave (G_ "~a: unknown backend~%") name)))
 428
 429 (define (list-node-types)
 430   "Print the available node types along with their synopsis."
 431   (display (G_ "The available node types are:\n"))
 432   (newline)
 433   (for-each (lambda (type)
 434               (format #t "  - ~a: ~a~%"
 435                       (node-type-name type)
 436                       (node-type-description type)))
 437             %node-types))
 438
 439 (define (list-backends)
 440   "Print the available backends along with their synopsis."
 441   (display (G_ "The available backend types are:\n"))
 442   (newline)
 443   (for-each (lambda (backend)
 444               (format #t "  - ~a: ~a~%"
 445                       (graph-backend-name backend)
 446                       (graph-backend-description backend)))
 447             %graph-backends))
 448
 449 \f
 450 ;;;
 451 ;;; Command-line options.
 452 ;;;
 453
 454 (define %options
 455   (cons* (option '(#\t "type") #t #f
 456                  (lambda (opt name arg result)
 457                    (alist-cons 'node-type (lookup-node-type arg)
 458                                result)))
 459          (option '("list-types") #f #f
 460                  (lambda (opt name arg result)
 461                    (list-node-types)
 462                    (exit 0)))
 463          (option '(#\b "backend") #t #f
 464                  (lambda (opt name arg result)
 465                    (alist-cons 'backend (lookup-backend arg)
 466                                result)))
 467          (option '("list-backends") #f #f
 468                  (lambda (opt name arg result)
 469                    (list-backends)
 470                    (exit 0)))
 471          (option '(#\e "expression") #t #f
 472                  (lambda (opt name arg result)
 473                    (alist-cons 'expression arg result)))
 474          (option '(#\s "system") #t #f
 475                  (lambda (opt name arg result)
 476                    (alist-cons 'system arg
 477                                (alist-delete 'system result eq?))))
 478          (find (lambda (option)
 479                 (member "load-path" (option-names option)))
 480               %standard-build-options)
 481          (option '(#\h "help") #f #f
 482                  (lambda args
 483                    (show-help)
 484                    (exit 0)))
 485          (option '(#\V "version") #f #f
 486                  (lambda args
 487                    (show-version-and-exit "guix graph")))
 488
 489          %transformation-options))
 490
 491 (define (show-help)
 492   ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
 493   ;; translated.
 494   (display (G_ "Usage: guix graph PACKAGE...
 495 Emit a representation of the dependency graph of PACKAGE...\n"))
 496   (display (G_ "
 497   -b, --backend=TYPE     produce a graph with the given backend TYPE"))
 498   (display (G_ "
 499       --list-backends    list the available graph backends"))
 500   (display (G_ "
 501   -t, --type=TYPE        represent nodes of the given TYPE"))
 502   (display (G_ "
 503       --list-types       list the available graph types"))
 504   (display (G_ "
 505   -e, --expression=EXPR  consider the package EXPR evaluates to"))
 506   (display (G_ "
 507   -s, --system=SYSTEM    consider the graph for SYSTEM--e.g., \"i686-linux\""))
 508   (newline)
 509   (display (G_ "
 510   -L, --load-path=DIR    prepend DIR to the package module search path"))
 511   (newline)
 512   (show-transformation-options-help)
 513   (newline)
 514   (display (G_ "
 515   -h, --help             display this help and exit"))
 516   (display (G_ "
 517   -V, --version          display version information and exit"))
 518   (newline)
 519   (show-bug-report-information))
 520
 521 (define %default-options
 522   `((node-type . ,%package-node-type)
 523     (backend   . ,%graphviz-backend)
 524     (system    . ,(%current-system))))
 525
 526 \f
 527 ;;;
 528 ;;; Entry point.
 529 ;;;
 530
 531 (define (guix-graph . args)
 532   (with-error-handling
 533     (define opts
 534       (parse-command-line args %options
 535                           (list %default-options)
 536                           #:build-options? #f))
 537     (define backend
 538       (assoc-ref opts 'backend))
 539     (define type
 540       (assoc-ref opts 'node-type))
 541
 542     (with-store store
 543       (let* ((transform (options->transformation opts))
 544              (items     (filter-map (match-lambda
 545                                       (('argument . (? store-path? item))
 546                                        item)
 547                                       (('argument . spec)
 548                                        (transform store
 549                                                   (specification->package spec)))
 550                                       (('expression . exp)
 551                                        (transform store
 552                                                   (read/eval-package-expression exp)))
 553                                       (_ #f))
 554                                     opts)))
 555         (run-with-store store
 556           ;; XXX: Since grafting can trigger unsolicited builds, disable it.
 557           (mlet %store-monad ((_     (set-grafting #f))
 558                               (nodes (mapm %store-monad
 559                                            (node-type-convert type)
 560                                            items)))
 561             (export-graph (concatenate nodes)
 562                           (current-output-port)
 563                           #:node-type type
 564                           #:backend backend))
 565           #:system (assq-ref opts 'system)))))
 566   #t)
 567
 568 ;;; graph.scm ends here