guix/scripts/graph.scm

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