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