guix/grafts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 grafts)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix records)
  23   #:use-module (guix combinators)
  24   #:use-module (guix derivations)
  25   #:use-module ((guix utils) #:select (%current-system))
  26   #:use-module (guix sets)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-9 gnu)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (ice-9 match)
  33   #:use-module (ice-9 vlist)
  34   #:export (graft?
  35             graft
  36             graft-origin
  37             graft-replacement
  38             graft-origin-output
  39             graft-replacement-output
  40
  41             graft-derivation
  42             graft-derivation/shallow
  43
  44             %graft?
  45             set-grafting
  46             grafting?))
  47
  48 (define-record-type* <graft> graft make-graft
  49   graft?
  50   (origin             graft-origin)               ;derivation | store item
  51   (origin-output      graft-origin-output         ;string | #f
  52                       (default "out"))
  53   (replacement        graft-replacement)          ;derivation | store item
  54   (replacement-output graft-replacement-output    ;string | #f
  55                       (default "out")))
  56
  57 (define (write-graft graft port)
  58   "Write a concise representation of GRAFT to PORT."
  59   (define (->string thing output)
  60     (if (derivation? thing)
  61         (derivation->output-path thing output)
  62         thing))
  63
  64   (match graft
  65     (($ <graft> origin origin-output replacement replacement-output)
  66      (format port "#<graft ~a ==> ~a ~a>"
  67              (->string origin origin-output)
  68              (->string replacement replacement-output)
  69              (number->string (object-address graft) 16)))))
  70
  71 (set-record-type-printer! <graft> write-graft)
  72
  73 (define (graft-origin-file-name graft)
  74   "Return the output file name of the origin of GRAFT."
  75   (match graft
  76     (($ <graft> (? derivation? origin) output)
  77      (derivation->output-path origin output))
  78     (($ <graft> (? string? item))
  79      item)))
  80
  81 (define* (graft-derivation/shallow store drv grafts
  82                                    #:key
  83                                    (name (derivation-name drv))
  84                                    (outputs (derivation-output-names drv))
  85                                    (guile (%guile-for-build))
  86                                    (system (%current-system)))
  87   "Return a derivation called NAME, which applies GRAFTS to the specified
  88 OUTPUTS of DRV.  This procedure performs \"shallow\" grafting in that GRAFTS
  89 are not recursively applied to dependencies of DRV."
  90   ;; XXX: Someday rewrite using gexps.
  91   (define mapping
  92     ;; List of store item pairs.
  93     (map (match-lambda
  94           (($ <graft> source source-output target target-output)
  95            (cons (if (derivation? source)
  96                      (derivation->output-path source source-output)
  97                      source)
  98                  (if (derivation? target)
  99                      (derivation->output-path target target-output)
 100                      target))))
 101          grafts))
 102
 103   (define output-pairs
 104     (map (lambda (output)
 105            (cons output
 106                  (derivation-output-path
 107                   (assoc-ref (derivation-outputs drv) output))))
 108          outputs))
 109
 110   (define build
 111     `(begin
 112        (use-modules (guix build graft)
 113                     (guix build utils)
 114                     (ice-9 match))
 115
 116        (let* ((old-outputs ',output-pairs)
 117               (mapping (append ',mapping
 118                                (map (match-lambda
 119                                       ((name . file)
 120                                        (cons (assoc-ref old-outputs name)
 121                                              file)))
 122                                     %outputs))))
 123          (graft old-outputs %outputs mapping))))
 124
 125   (define add-label
 126     (cut cons "x" <>))
 127
 128   (define properties
 129     `((type . graft)
 130       (graft (count . ,(length grafts)))))
 131
 132   (match grafts
 133     ((($ <graft> sources source-outputs targets target-outputs) ...)
 134      (let ((sources (zip sources source-outputs))
 135            (targets (zip targets target-outputs)))
 136        (build-expression->derivation store name build
 137                                      #:system system
 138                                      #:guile-for-build guile
 139                                      #:modules '((guix build graft)
 140                                                  (guix build utils)
 141                                                  (guix build debug-link)
 142                                                  (guix elf))
 143                                      #:inputs `(,@(map (lambda (out)
 144                                                          `("x" ,drv ,out))
 145                                                        outputs)
 146                                                 ,@(append (map add-label sources)
 147                                                           (map add-label targets)))
 148                                      #:outputs outputs
 149
 150                                      ;; Grafts are computationally cheap so no
 151                                      ;; need to offload or substitute.
 152                                      #:local-build? #t
 153                                      #:substitutable? #f
 154
 155                                      #:properties properties)))))
 156
 157 (define (non-self-references store drv outputs)
 158   "Return the list of references of the OUTPUTS of DRV, excluding self
 159 references."
 160   (define (references* items)
 161     ;; Return the references of ITEMS.
 162     (guard (c ((store-protocol-error? c)
 163                ;; ITEMS are not in store so build INPUT first.
 164                (and (build-derivations store (list drv))
 165                     (append-map (cut references/cached store <>) items))))
 166       (append-map (cut references/cached store <>) items)))
 167
 168   (let ((refs (references* (map (cut derivation->output-path drv <>)
 169                                 outputs)))
 170         (self (match (derivation->output-paths drv)
 171                 (((names . items) ...)
 172                  items))))
 173     (remove (cut member <> self) refs)))
 174
 175 (define-syntax-rule (with-cache key exp ...)
 176   "Cache the value of monadic expression EXP under KEY."
 177   (mlet %state-monad ((cache (current-state)))
 178     (match (vhash-assoc key cache)
 179       ((_ . result)                               ;cache hit
 180        (return result))
 181       (#f                                         ;cache miss
 182        (mlet %state-monad ((result (begin exp ...))
 183                            (cache  (current-state)))
 184          (mbegin %state-monad
 185            (set-current-state (vhash-cons key result cache))
 186            (return result)))))))
 187
 188 (define (reference-origins drv items)
 189   "Return the derivation/output pairs among the inputs of DRV, recursively,
 190 that produce ITEMS.  Elements of ITEMS not produced by a derivation (i.e.,
 191 it's a content-addressed \"source\"), or not produced by a dependency of DRV,
 192 have no corresponding element in the resulting list."
 193   (define (lookup-derivers drv result items)
 194     ;; Return RESULT augmented by all the drv/output pairs producing one of
 195     ;; ITEMS, and ITEMS stripped of matching items.
 196     (fold2 (match-lambda*
 197              (((output . file) result items)
 198               (if (member file items)
 199                   (values (alist-cons drv output result)
 200                           (delete file items))
 201                   (values result items))))
 202            result items
 203            (derivation->output-paths drv)))
 204
 205   ;; Perform a breadth-first traversal of the dependency graph of DRV in
 206   ;; search of the derivations that produce ITEMS.
 207   (let loop ((drv (list drv))
 208              (items items)
 209              (result '())
 210              (visited (setq)))
 211     (match drv
 212       (()
 213        result)
 214       ((drv . rest)
 215        (cond ((null? items)
 216               result)
 217              ((set-contains? visited drv)
 218               (loop rest items result visited))
 219              (else
 220               (let*-values (((inputs)
 221                              (map derivation-input-derivation
 222                                   (derivation-inputs drv)))
 223                             ((result items)
 224                              (fold2 lookup-derivers
 225                                     result items inputs)))
 226                 (loop (append rest inputs)
 227                       items result
 228                       (set-insert drv visited)))))))))
 229
 230 (define* (cumulative-grafts store drv grafts
 231                             #:key
 232                             (outputs (derivation-output-names drv))
 233                             (guile (%guile-for-build))
 234                             (system (%current-system)))
 235   "Augment GRAFTS with additional grafts resulting from the application of
 236 GRAFTS to the dependencies of DRV.  Return the resulting list of grafts.
 237
 238 This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
 239 derivations to the corresponding set of grafts."
 240   (define (graft-origin? drv graft)
 241     ;; Return true if DRV corresponds to the origin of GRAFT.
 242     (match graft
 243       (($ <graft> (? derivation? origin) output)
 244        (match (assoc-ref (derivation->output-paths drv) output)
 245          ((? string? result)
 246           (string=? result
 247                     (derivation->output-path origin output)))
 248          (_
 249           #f)))
 250       (_
 251        #f)))
 252
 253   (define (dependency-grafts items)
 254     (mapm %store-monad
 255           (lambda (drv+output)
 256             (match drv+output
 257               ((drv . output)
 258                ;; If GRAFTS already contains a graft from DRV, do not
 259                ;; override it.
 260                (if (find (cut graft-origin? drv <>) grafts)
 261                    (state-return grafts)
 262                    (cumulative-grafts store drv grafts
 263                                       #:outputs (list output)
 264                                       #:guile guile
 265                                       #:system system)))))
 266           (reference-origins drv items)))
 267
 268   (with-cache (cons (derivation-file-name drv) outputs)
 269     (match (non-self-references store drv outputs)
 270       (()                                         ;no dependencies
 271        (return grafts))
 272       (deps                                       ;one or more dependencies
 273        (mlet %state-monad ((grafts (dependency-grafts deps)))
 274          (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
 275            (match (filter (lambda (graft)
 276                             (member (graft-origin-file-name graft) deps))
 277                           grafts)
 278              (()
 279               (return grafts))
 280              ((applicable ..1)
 281               ;; Use APPLICABLE, the subset of GRAFTS that is really
 282               ;; applicable to DRV, to avoid creating several identical
 283               ;; grafted variants of DRV.
 284               (let* ((new    (graft-derivation/shallow store drv applicable
 285                                                        #:outputs outputs
 286                                                        #:guile guile
 287                                                        #:system system))
 288                      (grafts (append (map (lambda (output)
 289                                             (graft
 290                                               (origin drv)
 291                                               (origin-output output)
 292                                               (replacement new)
 293                                               (replacement-output output)))
 294                                           outputs)
 295                                      grafts)))
 296                 (return grafts))))))))))
 297
 298 (define* (graft-derivation store drv grafts
 299                            #:key
 300                            (guile (%guile-for-build))
 301                            (outputs (derivation-output-names drv))
 302                            (system (%current-system)))
 303   "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
 304 That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
 305 DRV, and graft DRV itself to refer to those grafted dependencies."
 306   (match (run-with-state
 307              (cumulative-grafts store drv grafts
 308                                 #:outputs outputs
 309                                 #:guile guile #:system system)
 310            vlist-null)                            ;the initial cache
 311     ((first . rest)
 312      ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
 313      ;; applicable to DRV and nothing needs to be done.
 314      (if (equal? drv (graft-origin first))
 315          (graft-replacement first)
 316          drv))))
 317
 318 \f
 319 ;; The following might feel more at home in (guix packages) but since (guix
 320 ;; gexp), which is a lower level, needs them, we put them here.
 321
 322 (define %graft?
 323   ;; Whether to honor package grafts by default.
 324   (make-parameter #t))
 325
 326 (define (set-grafting enable?)
 327   "This monadic procedure enables grafting when ENABLE? is true, and disables
 328 it otherwise.  It returns the previous setting."
 329   (lambda (store)
 330     (values (%graft? enable?) store)))
 331
 332 (define (grafting?)
 333   "Return a Boolean indicating whether grafting is enabled."
 334   (lambda (store)
 335     (values (%graft?) store)))
 336
 337 ;; Local Variables:
 338 ;; eval: (put 'with-cache 'scheme-indent-function 1)
 339 ;; End:
 340
 341 ;;; grafts.scm ends here