guix/grafts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016 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 records)
  21   #:use-module (guix derivations)
  22   #:use-module ((guix utils) #:select (%current-system))
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (ice-9 match)
  26   #:export (graft?
  27             graft
  28             graft-origin
  29             graft-replacement
  30             graft-origin-output
  31             graft-replacement-output
  32
  33             graft-derivation
  34
  35             %graft?
  36             set-grafting))
  37
  38 (define-record-type* <graft> graft make-graft
  39   graft?
  40   (origin             graft-origin)               ;derivation | store item
  41   (origin-output      graft-origin-output         ;string | #f
  42                       (default "out"))
  43   (replacement        graft-replacement)          ;derivation | store item
  44   (replacement-output graft-replacement-output    ;string | #f
  45                       (default "out")))
  46
  47 (define* (graft-derivation store drv grafts
  48                            #:key
  49                            (name (derivation-name drv))
  50                            (guile (%guile-for-build))
  51                            (system (%current-system)))
  52   "Return a derivation called NAME, based on DRV but with all the GRAFTS
  53 applied."
  54   ;; XXX: Someday rewrite using gexps.
  55   (define mapping
  56     ;; List of store item pairs.
  57     (map (match-lambda
  58           (($ <graft> source source-output target target-output)
  59            (cons (if (derivation? source)
  60                      (derivation->output-path source source-output)
  61                      source)
  62                  (if (derivation? target)
  63                      (derivation->output-path target target-output)
  64                      target))))
  65          grafts))
  66
  67   (define outputs
  68     (match (derivation-outputs drv)
  69       (((names . outputs) ...)
  70        (map derivation-output-path outputs))))
  71
  72   (define output-names
  73     (match (derivation-outputs drv)
  74       (((names . outputs) ...)
  75        names)))
  76
  77   (define build
  78     `(begin
  79        (use-modules (guix build graft)
  80                     (guix build utils)
  81                     (ice-9 match))
  82
  83        (let ((mapping ',mapping))
  84          (for-each (lambda (input output)
  85                      (format #t "grafting '~a' -> '~a'...~%" input output)
  86                      (force-output)
  87                      (rewrite-directory input output
  88                                         `((,input . ,output)
  89                                           ,@mapping)))
  90                    ',outputs
  91                    (match %outputs
  92                      (((names . files) ...)
  93                       files))))))
  94
  95   (define add-label
  96     (cut cons "x" <>))
  97
  98   (match grafts
  99     ((($ <graft> sources source-outputs targets target-outputs) ...)
 100      (let ((sources (zip sources source-outputs))
 101            (targets (zip targets target-outputs)))
 102        (build-expression->derivation store name build
 103                                      #:system system
 104                                      #:guile-for-build guile
 105                                      #:modules '((guix build graft)
 106                                                  (guix build utils))
 107                                      #:inputs `(,@(map (lambda (out)
 108                                                          `("x" ,drv ,out))
 109                                                        output-names)
 110                                                 ,@(append (map add-label sources)
 111                                                           (map add-label targets)))
 112                                      #:outputs output-names
 113                                      #:local-build? #t)))))
 114
 115 \f
 116 ;; The following might feel more at home in (guix packages) but since (guix
 117 ;; gexp), which is a lower level, needs them, we put them here.
 118
 119 (define %graft?
 120   ;; Whether to honor package grafts by default.
 121   (make-parameter #t))
 122
 123 (define (set-grafting enable?)
 124   "This monadic procedure enables grafting when ENABLE? is true, and disables
 125 it otherwise.  It returns the previous setting."
 126   (lambda (store)
 127     (values (%graft? enable?) store)))
 128
 129 ;;; grafts.scm ends here