guix/grafts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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-9 gnu)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-71)
  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 %graft-cache
 176   ;; Cache that maps derivation/outputs/grafts tuples to lists of grafts.
 177   (allocate-store-connection-cache 'grafts))
 178
 179 (define record-cache-lookup!
 180   (cache-lookup-recorder "derivation-graft-cache"
 181                          "Derivation graft cache"))
 182
 183 (define-syntax-rule (with-cache key exp ...)
 184   "Cache the value of monadic expression EXP under KEY."
 185   (mlet* %state-monad ((cache (current-state))
 186                        (result -> (vhash-assoc key cache)))
 187     (record-cache-lookup! result cache)
 188     (match result
 189       ((_ . result)                               ;cache hit
 190        (return result))
 191       (#f                                         ;cache miss
 192        (mlet %state-monad ((result (begin exp ...))
 193                            (cache  (current-state)))
 194          (mbegin %state-monad
 195            (set-current-state (vhash-cons key result cache))
 196            (return result)))))))
 197
 198 (define (reference-origins drv items)
 199   "Return the derivation/output pairs among the inputs of DRV, recursively,
 200 that produce ITEMS.  Elements of ITEMS not produced by a derivation (i.e.,
 201 it's a content-addressed \"source\"), or not produced by a dependency of DRV,
 202 have no corresponding element in the resulting list."
 203   (define (lookup-derivers drv result items)
 204     ;; Return RESULT augmented by all the drv/output pairs producing one of
 205     ;; ITEMS, and ITEMS stripped of matching items.
 206     (fold2 (match-lambda*
 207              (((output . file) result items)
 208               (if (member file items)
 209                   (values (alist-cons drv output result)
 210                           (delete file items))
 211                   (values result items))))
 212            result items
 213            (derivation->output-paths drv)))
 214
 215   ;; Perform a breadth-first traversal of the dependency graph of DRV in
 216   ;; search of the derivations that produce ITEMS.
 217   (let loop ((drv (list drv))
 218              (items items)
 219              (result '())
 220              (visited (setq)))
 221     (match drv
 222       (()
 223        result)
 224       ((drv . rest)
 225        (cond ((null? items)
 226               result)
 227              ((set-contains? visited drv)
 228               (loop rest items result visited))
 229              (else
 230               (let* ((inputs
 231                       (map derivation-input-derivation
 232                            (derivation-inputs drv)))
 233                      (result items
 234                              (fold2 lookup-derivers
 235                                     result items inputs)))
 236                 (loop (append rest inputs)
 237                       items result
 238                       (set-insert drv visited)))))))))
 239
 240 (define* (cumulative-grafts store drv grafts
 241                             #:key
 242                             (outputs (derivation-output-names drv))
 243                             (guile (%guile-for-build))
 244                             (system (%current-system)))
 245   "Augment GRAFTS with additional grafts resulting from the application of
 246 GRAFTS to the dependencies of DRV.  Return the resulting list of grafts.
 247
 248 This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
 249 derivations to the corresponding set of grafts."
 250   (define (graft-origin? drv graft)
 251     ;; Return true if DRV corresponds to the origin of GRAFT.
 252     (match graft
 253       (($ <graft> (? derivation? origin) output)
 254        (match (assoc-ref (derivation->output-paths drv) output)
 255          ((? string? result)
 256           (string=? result
 257                     (derivation->output-path origin output)))
 258          (_
 259           #f)))
 260       (_
 261        #f)))
 262
 263   (define (dependency-grafts items)
 264     (mapm %store-monad
 265           (lambda (drv+output)
 266             (match drv+output
 267               ((drv . output)
 268                ;; If GRAFTS already contains a graft from DRV, do not
 269                ;; override it.
 270                (if (find (cut graft-origin? drv <>) grafts)
 271                    (state-return grafts)
 272                    (cumulative-grafts store drv grafts
 273                                       #:outputs (list output)
 274                                       #:guile guile
 275                                       #:system system)))))
 276           (reference-origins drv items)))
 277
 278   (with-cache (list (derivation-file-name drv) outputs grafts)
 279     (match (non-self-references store drv outputs)
 280       (()                                         ;no dependencies
 281        (return grafts))
 282       (deps                                       ;one or more dependencies
 283        (mlet %state-monad ((grafts (dependency-grafts deps)))
 284          (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
 285            (match (filter (lambda (graft)
 286                             (member (graft-origin-file-name graft) deps))
 287                           grafts)
 288              (()
 289               (return grafts))
 290              ((applicable ..1)
 291               ;; Use APPLICABLE, the subset of GRAFTS that is really
 292               ;; applicable to DRV, to avoid creating several identical
 293               ;; grafted variants of DRV.
 294               (let* ((new    (graft-derivation/shallow store drv applicable
 295                                                        #:outputs outputs
 296                                                        #:guile guile
 297                                                        #:system system))
 298                      (grafts (append (map (lambda (output)
 299                                             (graft
 300                                               (origin drv)
 301                                               (origin-output output)
 302                                               (replacement new)
 303                                               (replacement-output output)))
 304                                           outputs)
 305                                      grafts)))
 306                 (return grafts))))))))))
 307
 308 (define* (graft-derivation store drv grafts
 309                            #:key
 310                            (guile (%guile-for-build))
 311                            (outputs (derivation-output-names drv))
 312                            (system (%current-system)))
 313   "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
 314 That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
 315 DRV, and graft DRV itself to refer to those grafted dependencies."
 316   (let ((grafts cache
 317                 (run-with-state
 318                     (cumulative-grafts store drv grafts
 319                                        #:outputs outputs
 320                                        #:guile guile #:system system)
 321                   (store-connection-cache store %graft-cache))))
 322
 323     ;; Save CACHE in STORE to benefit from it on the next call.
 324     ;; XXX: Ideally we'd use %STORE-MONAD and 'mcached' and avoid mutating
 325     ;; STORE.
 326     (set-store-connection-cache! store %graft-cache cache)
 327
 328     (match grafts
 329       ((first . rest)
 330        ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
 331        ;; applicable to DRV and nothing needs to be done.
 332        (if (equal? drv (graft-origin first))
 333            (graft-replacement first)
 334            drv)))))
 335
 336 \f
 337 ;; The following might feel more at home in (guix packages) but since (guix
 338 ;; gexp), which is a lower level, needs them, we put them here.
 339
 340 (define %graft?
 341   ;; Whether to honor package grafts by default.
 342   (make-parameter #t))
 343
 344 (define-inlinable (set-grafting enable?)
 345   ;; This monadic procedure enables grafting when ENABLE? is true, and
 346   ;; disables it otherwise.  It returns the previous setting.
 347   (lambda (store)
 348     (values (%graft? enable?) store)))
 349
 350 (define-inlinable (grafting?)
 351   ;; Return a Boolean indicating whether grafting is enabled.
 352   (lambda (store)
 353     (values (%graft?) store)))
 354
 355 ;; Local Variables:
 356 ;; eval: (put 'with-cache 'scheme-indent-function 1)
 357 ;; End:
 358
 359 ;;; grafts.scm ends here