guix/derivations.scm

   1 ;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
   2 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of Guix.
   5 ;;;
   6 ;;; 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 ;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix derivations)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (srfi srfi-26)
  23   #:use-module (rnrs io ports)
  24   #:use-module (rnrs bytevectors)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (guix store)
  28   #:use-module (guix utils)
  29   #:export (<derivation>
  30             derivation?
  31             derivation-outputs
  32             derivation-inputs
  33             derivation-sources
  34             derivation-system
  35             derivation-builder-arguments
  36             derivation-builder-environment-vars
  37             derivation-prerequisites
  38             derivation-prerequisites-to-build
  39
  40             <derivation-output>
  41             derivation-output?
  42             derivation-output-path
  43             derivation-output-hash-algo
  44             derivation-output-hash
  45
  46             <derivation-input>
  47             derivation-input?
  48             derivation-input-path
  49             derivation-input-sub-derivations
  50
  51             fixed-output-derivation?
  52             derivation-hash
  53
  54             read-derivation
  55             write-derivation
  56             derivation-path->output-path
  57             derivation
  58
  59             %guile-for-build
  60             build-expression->derivation
  61             imported-files))
  62
  63 ;;;
  64 ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
  65 ;;;
  66
  67 (define-record-type <derivation>
  68   (make-derivation outputs inputs sources system builder args env-vars)
  69   derivation?
  70   (outputs  derivation-outputs)      ; list of name/<derivation-output> pairs
  71   (inputs   derivation-inputs)       ; list of <derivation-input>
  72   (sources  derivation-sources)      ; list of store paths
  73   (system   derivation-system)       ; string
  74   (builder  derivation-builder)      ; store path
  75   (args     derivation-builder-arguments)         ; list of strings
  76   (env-vars derivation-builder-environment-vars)) ; list of name/value pairs
  77
  78 (define-record-type <derivation-output>
  79   (make-derivation-output path hash-algo hash)
  80   derivation-output?
  81   (path       derivation-output-path)             ; store path
  82   (hash-algo  derivation-output-hash-algo)        ; symbol | #f
  83   (hash       derivation-output-hash))            ; bytevector | #f
  84
  85 (define-record-type <derivation-input>
  86   (make-derivation-input path sub-derivations)
  87   derivation-input?
  88   (path            derivation-input-path)             ; store path
  89   (sub-derivations derivation-input-sub-derivations)) ; list of strings
  90
  91 (define (fixed-output-derivation? drv)
  92   "Return #t if DRV is a fixed-output derivation, such as the result of a
  93 download with a fixed hash (aka. `fetchurl')."
  94   (match drv
  95     (($ <derivation>
  96         (($ <derivation-output> _ (? symbol?) (? string?))))
  97      #t)
  98     (_ #f)))
  99
 100 (define (derivation-prerequisites drv)
 101   "Return the list of derivation-inputs required to build DRV, recursively."
 102   (let loop ((drv    drv)
 103              (result '()))
 104     (let ((inputs (remove (cut member <> result)  ; XXX: quadratic
 105                           (derivation-inputs drv))))
 106       (fold loop
 107             (append inputs result)
 108             (map (lambda (i)
 109                    (call-with-input-file (derivation-input-path i)
 110                      read-derivation))
 111                  inputs)))))
 112
 113 (define (derivation-prerequisites-to-build store drv)
 114   "Return the list of derivation-inputs required to build DRV and not already
 115 available in STORE, recursively."
 116   (define input-built?
 117     (match-lambda
 118      (($ <derivation-input> path sub-drvs)
 119       (let ((out (map (cut derivation-path->output-path path <>)
 120                       sub-drvs)))
 121         (any (cut valid-path? store <>) out)))))
 122
 123   (let loop ((drv    drv)
 124              (result '()))
 125     (let ((inputs (remove (lambda (i)
 126                             (or (member i result) ; XXX: quadratic
 127                                 (input-built? i)))
 128                           (derivation-inputs drv))))
 129       (fold loop
 130             (append inputs result)
 131             (map (lambda (i)
 132                    (call-with-input-file (derivation-input-path i)
 133                      read-derivation))
 134                  inputs)))))
 135
 136 (define (read-derivation drv-port)
 137   "Read the derivation from DRV-PORT and return the corresponding
 138 <derivation> object."
 139
 140   (define comma (string->symbol ","))
 141
 142   (define (ununquote x)
 143     (match x
 144       (('unquote x) (ununquote x))
 145       ((x ...)      (map ununquote x))
 146       (_            x)))
 147
 148   (define (outputs->alist x)
 149     (fold-right (lambda (output result)
 150                   (match output
 151                     ((name path "" "")
 152                      (alist-cons name
 153                                  (make-derivation-output path #f #f)
 154                                  result))
 155                     ((name path hash-algo hash)
 156                      ;; fixed-output
 157                      (let ((algo (string->symbol hash-algo))
 158                            (hash (base16-string->bytevector hash)))
 159                        (alist-cons name
 160                                    (make-derivation-output path algo hash)
 161                                    result)))))
 162                 '()
 163                 x))
 164
 165   (define (make-input-drvs x)
 166     (fold-right (lambda (input result)
 167                   (match input
 168                     ((path (sub-drvs ...))
 169                      (cons (make-derivation-input path sub-drvs)
 170                            result))))
 171                 '()
 172                 x))
 173
 174   (let loop ((exp    (read drv-port))
 175              (result '()))
 176     (match exp
 177       ((? eof-object?)
 178        (let ((result (reverse result)))
 179          (match result
 180            (('Derive ((outputs ...) (input-drvs ...)
 181                       (input-srcs ...)
 182                       (? string? system)
 183                       (? string? builder)
 184                       ((? string? args) ...)
 185                       ((var value) ...)))
 186             (make-derivation (outputs->alist outputs)
 187                              (make-input-drvs input-drvs)
 188                              input-srcs
 189                              system builder args
 190                              (fold-right alist-cons '() var value)))
 191            (_
 192             (error "failed to parse derivation" drv-port result)))))
 193       ((? (cut eq? <> comma))
 194        (loop (read drv-port) result))
 195       (_
 196        (loop (read drv-port)
 197              (cons (ununquote exp) result))))))
 198
 199 (define (write-derivation drv port)
 200   "Write the ATerm-like serialization of DRV to PORT.  See Section 2.4 of
 201 Eelco Dolstra's PhD dissertation for an overview of a previous version of
 202 that form."
 203   (define (list->string lst)
 204     (string-append "[" (string-join lst ",") "]"))
 205
 206   (define (write-list lst)
 207     (display (list->string lst) port))
 208
 209   (match drv
 210     (($ <derivation> outputs inputs sources
 211         system builder args env-vars)
 212      (display "Derive(" port)
 213      (write-list (map (match-lambda
 214                        ((name . ($ <derivation-output> path hash-algo hash))
 215                         (format #f "(~s,~s,~s,~s)"
 216                                 name path
 217                                 (or (and=> hash-algo symbol->string) "")
 218                                 (or (and=> hash bytevector->base16-string)
 219                                     ""))))
 220                       outputs))
 221      (display "," port)
 222      (write-list (map (match-lambda
 223                        (($ <derivation-input> path sub-drvs)
 224                         (format #f "(~s,~a)" path
 225                                 (list->string (map object->string sub-drvs)))))
 226                       inputs))
 227      (display "," port)
 228      (write-list (map object->string sources))
 229      (format port ",~s,~s," system builder)
 230      (write-list (map object->string args))
 231      (display "," port)
 232      (write-list (map (match-lambda
 233                        ((name . value)
 234                         (format #f "(~s,~s)" name value)))
 235                       env-vars))
 236      (display ")" port))))
 237
 238 (define* (derivation-path->output-path path #:optional (output "out"))
 239   "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
 240 path of its output OUTPUT."
 241   (let* ((drv     (call-with-input-file path read-derivation))
 242          (outputs (derivation-outputs drv)))
 243     (and=> (assoc-ref outputs output) derivation-output-path)))
 244
 245 \f
 246 ;;;
 247 ;;; Derivation primitive.
 248 ;;;
 249
 250 (define (compressed-hash bv size)                 ; `compressHash'
 251   "Given the hash stored in BV, return a compressed version thereof that fits
 252 in SIZE bytes."
 253   (define new (make-bytevector size 0))
 254   (define old-size (bytevector-length bv))
 255   (let loop ((i 0))
 256     (if (= i old-size)
 257         new
 258         (let* ((j (modulo i size))
 259                (o (bytevector-u8-ref new j)))
 260           (bytevector-u8-set! new j
 261                               (logxor o (bytevector-u8-ref bv i)))
 262           (loop (+ 1 i))))))
 263
 264 (define derivation-hash            ; `hashDerivationModulo' in derivations.cc
 265   (memoize
 266    (lambda (drv)
 267     "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
 268     (match drv
 269       (($ <derivation> ((_ . ($ <derivation-output> path
 270                                 (? symbol? hash-algo) (? bytevector? hash)))))
 271        ;; A fixed-output derivation.
 272        (sha256
 273         (string->utf8
 274          (string-append "fixed:out:" (symbol->string hash-algo)
 275                         ":" (bytevector->base16-string hash)
 276                         ":" path))))
 277       (($ <derivation> outputs inputs sources
 278           system builder args env-vars)
 279        ;; A regular derivation: replace the path of each input with that
 280        ;; input's hash; return the hash of serialization of the resulting
 281        ;; derivation.  Note: inputs are sorted as in the order of their hex
 282        ;; hash representation because that's what the C++ `std::map' code
 283        ;; does.
 284        (let* ((inputs  (sort (map (match-lambda
 285                                    (($ <derivation-input> path sub-drvs)
 286                                     (let ((hash (call-with-input-file path
 287                                                   (compose bytevector->base16-string
 288                                                            derivation-hash
 289                                                            read-derivation))))
 290                                       (make-derivation-input hash sub-drvs))))
 291                                   inputs)
 292                              (lambda (i1 i2)
 293                                (string<? (derivation-input-path i1)
 294                                          (derivation-input-path i2)))))
 295               (sources (sort sources string<?))
 296               (outputs (sort outputs
 297                              (lambda (o1 o2)
 298                                (string<? (car o1) (car o2)))))
 299               (drv     (make-derivation outputs inputs sources
 300                                         system builder args env-vars)))
 301          (sha256
 302           (string->utf8 (call-with-output-string
 303                          (cut write-derivation drv <>))))))))))
 304
 305 (define (store-path type hash name)               ; makeStorePath
 306   "Return the store path for NAME/HASH/TYPE."
 307   (let* ((s (string-append type ":sha256:"
 308                            (bytevector->base16-string hash) ":"
 309                            (%store-prefix) ":" name))
 310          (h (sha256 (string->utf8 s)))
 311          (c (compressed-hash h 20)))
 312     (string-append (%store-prefix) "/"
 313                    (bytevector->nix-base32-string c) "-"
 314                    name)))
 315
 316 (define (output-path output hash name)            ; makeOutputPath
 317   "Return an output path for OUTPUT (the name of the output as a string) of
 318 the derivation called NAME with hash HASH."
 319   (store-path (string-append "output:" output) hash
 320               (if (string=? output "out")
 321                   name
 322                   (string-append name "-" output))))
 323
 324 (define* (derivation store name system builder args env-vars inputs
 325                      #:key (outputs '("out")) hash hash-algo hash-mode)
 326   "Build a derivation with the given arguments.  Return the resulting
 327 store path and <derivation> object.  When HASH, HASH-ALGO, and HASH-MODE
 328 are given, a fixed-output derivation is created---i.e., one whose result is
 329 known in advance, such as a file download."
 330   (define (add-output-paths drv)
 331     ;; Return DRV with an actual store path for each of its output and the
 332     ;; corresponding environment variable.
 333     (match drv
 334       (($ <derivation> outputs inputs sources
 335           system builder args env-vars)
 336        (let* ((drv-hash (derivation-hash drv))
 337               (outputs  (map (match-lambda
 338                               ((output-name . ($ <derivation-output>
 339                                                  _ algo hash))
 340                                (let ((path (output-path output-name
 341                                                         drv-hash name)))
 342                                  (cons output-name
 343                                        (make-derivation-output path algo
 344                                                                hash)))))
 345                              outputs)))
 346          (make-derivation outputs inputs sources system builder args
 347                           (map (match-lambda
 348                                 ((name . value)
 349                                  (cons name
 350                                        (or (and=> (assoc-ref outputs name)
 351                                                   derivation-output-path)
 352                                            value))))
 353                                env-vars))))))
 354
 355   (define (env-vars-with-empty-outputs)
 356     ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
 357     ;; empty string, even outputs that do not appear in ENV-VARS.  Note: the
 358     ;; result is sorted alphabetically, as with C++ `std::map'.
 359     (let ((e (map (match-lambda
 360                    ((name . val)
 361                     (if (member name outputs)
 362                         (cons name "")
 363                         (cons name val))))
 364                   env-vars)))
 365       (sort (fold (lambda (output-name env-vars)
 366                     (if (assoc output-name env-vars)
 367                         env-vars
 368                         (append env-vars `((,output-name . "")))))
 369                   e
 370                   outputs)
 371             (lambda (e1 e2)
 372               (string<? (car e1) (car e2))))))
 373
 374   (let* ((outputs    (map (lambda (name)
 375                             ;; Return outputs with an empty path.
 376                             (cons name
 377                                   (make-derivation-output "" hash-algo hash)))
 378                           outputs))
 379          (inputs     (map (match-lambda
 380                            (((? store-path? input))
 381                             (make-derivation-input input '("out")))
 382                            (((? store-path? input) sub-drvs ...)
 383                             (make-derivation-input input sub-drvs))
 384                            ((input . _)
 385                             (let ((path (add-to-store store
 386                                                       (basename input)
 387                                                       (hash-algo sha256) #t #t
 388                                                       input)))
 389                               (make-derivation-input path '()))))
 390                           (delete-duplicates inputs)))
 391          (env-vars   (env-vars-with-empty-outputs))
 392          (drv-masked (make-derivation outputs
 393                                       (filter (compose derivation-path?
 394                                                        derivation-input-path)
 395                                               inputs)
 396                                       (filter-map (lambda (i)
 397                                                     (let ((p (derivation-input-path i)))
 398                                                       (and (not (derivation-path? p))
 399                                                            p)))
 400                                                   inputs)
 401                                       system builder args env-vars))
 402          (drv        (add-output-paths drv-masked)))
 403
 404     (values (add-text-to-store store (string-append name ".drv")
 405                                (call-with-output-string
 406                                 (cut write-derivation drv <>))
 407                                (map derivation-input-path
 408                                     inputs))
 409             drv)))
 410
 411 \f
 412 ;;;
 413 ;;; Guile-based builders.
 414 ;;;
 415
 416 (define %guile-for-build
 417   ;; The derivation of the Guile to be used within the build environment,
 418   ;; when using `build-expression->derivation'.
 419   (make-parameter (false-if-exception (nixpkgs-derivation "guile"))))
 420
 421 (define* (imported-files store files
 422                          #:key (name "file-import") (system (%current-system)))
 423   "Return a derivation that imports FILES into STORE.  FILES must be a list
 424 of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
 425 system, imported, and appears under FINAL-PATH in the resulting store path."
 426   (define (parent-dirs file-name)
 427     ;; Return the list of parent dirs of FILE-NAME, in the order in which an
 428     ;; `mkdir -p' implementation would make them.
 429     (let ((not-slash (char-set-complement (char-set #\/))))
 430       (reverse
 431        (fold (lambda (dir result)
 432                (match result
 433                  (()
 434                   (list dir))
 435                  ((prev _ ...)
 436                   (cons (string-append prev "/" dir)
 437                         result))))
 438              '()
 439              (remove (cut string=? <> ".")
 440                      (string-tokenize (dirname file-name) not-slash))))))
 441
 442   (let* ((files   (map (match-lambda
 443                         ((final-path . file-name)
 444                          (list final-path
 445                                (add-to-store store (basename final-path) #t #f
 446                                              "sha256" file-name))))
 447                        files))
 448          (builder
 449           `(begin
 450              (mkdir %output) (chdir %output)
 451              ,@(append-map (match-lambda
 452                             ((final-path store-path)
 453                              (append (match (parent-dirs final-path)
 454                                        (() '())
 455                                        ((head ... tail)
 456                                         (append (map (lambda (d)
 457                                                        `(false-if-exception
 458                                                          (mkdir ,d)))
 459                                                      head)
 460                                                 `((or (file-exists? ,tail)
 461                                                       (mkdir ,tail))))))
 462                                      `((symlink ,store-path ,final-path)))))
 463                            files))))
 464     (build-expression->derivation store name (%current-system)
 465                                   builder files)))
 466
 467 (define* (imported-modules store modules
 468                            #:key (name "module-import")
 469                            (system (%current-system)))
 470   "Return a derivation that contains the source files of MODULES, a list of
 471 module names such as `(ice-9 q)'.  All of MODULES must be in the current
 472 search path."
 473   ;; TODO: Determine the closure of MODULES, build the `.go' files,
 474   ;; canonicalize the source files through read/write, etc.
 475   (let ((files (map (lambda (m)
 476                       (let ((f (string-append
 477                                 (string-join (map symbol->string m) "/")
 478                                 ".scm")))
 479                         (cons f (search-path %load-path f))))
 480                     modules)))
 481     (imported-files store files #:name name #:system system)))
 482
 483
 484 (define* (build-expression->derivation store name system exp inputs
 485                                        #:key (outputs '("out"))
 486                                        hash hash-algo
 487                                        (modules '()))
 488   "Return a derivation that executes Scheme expression EXP as a builder for
 489 derivation NAME.  INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples;
 490 when SUB-DRV is omitted, \"out\" is assumed.  EXP is evaluated in an
 491 environment where %OUTPUT is bound to the main output path, %OUTPUTS is bound
 492 to a list of output/path pairs, and where %BUILD-INPUTS is bound to an alist
 493 of string/output-path pairs made from INPUTS.  The builder terminates by
 494 passing the result of EXP to `exit'; thus, when EXP returns #f, the build is
 495 considered to have failed."
 496   (define guile
 497     (string-append (derivation-path->output-path (%guile-for-build))
 498                    "/bin/guile"))
 499
 500   (define module-form?
 501     (match-lambda
 502       (((or 'define-module 'use-modules) _ ...) #t)
 503       (_ #f)))
 504
 505   (let* ((prologue `(begin
 506                       ,@(match exp
 507                           ((_ ...)
 508                            ;; Module forms must appear at the top-level so
 509                            ;; that any macros they export can be expanded.
 510                            (filter module-form? exp))
 511                           (_ `(,exp)))
 512
 513                       (define %output (getenv "out"))
 514                       (define %outputs
 515                         (map (lambda (o)
 516                                (cons o (getenv o)))
 517                              ',outputs))
 518                       (define %build-inputs
 519                         ',(map (match-lambda
 520                                 ((name drv . rest)
 521                                  (let ((sub (match rest
 522                                               (() "out")
 523                                               ((x) x))))
 524                                    (cons name
 525                                          (if (derivation-path? drv)
 526                                              (derivation-path->output-path drv
 527                                                                            sub)
 528                                              drv)))))
 529                                inputs))))
 530          (builder  (add-text-to-store store
 531                                       (string-append name "-guile-builder")
 532                                       (string-append
 533                                        (object->string prologue)
 534                                        (object->string
 535                                         `(exit
 536                                           ,(match exp
 537                                              ((_ ...)
 538                                               (remove module-form? exp))
 539                                              (_ `(,exp))))))
 540                                       (map second inputs)))
 541          (mod-drv  (if (null? modules)
 542                        #f
 543                        (imported-modules store modules)))
 544          (mod-dir  (and mod-drv
 545                         (derivation-path->output-path mod-drv))))
 546     (derivation store name system guile
 547                 `("--no-auto-compile"
 548                   ,@(if mod-dir `("-L" ,mod-dir) '())
 549                   ,builder)
 550                 '(("HOME" . "/homeless"))
 551                 `((,(%guile-for-build))
 552                   (,builder)
 553                   ,@(map cdr inputs)
 554                   ,@(if mod-drv `((,mod-drv)) '()))
 555                 #:hash hash #:hash-algo hash-algo
 556                 #:outputs outputs)))