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