585 lines
25 KiB
Scheme
585 lines
25 KiB
Scheme
;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
|
||
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of Guix.
|
||
;;;
|
||
;;; Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix derivations)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (rnrs io ports)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 rdelim)
|
||
#:use-module (guix store)
|
||
#:use-module (guix utils)
|
||
#:export (<derivation>
|
||
derivation?
|
||
derivation-outputs
|
||
derivation-inputs
|
||
derivation-sources
|
||
derivation-system
|
||
derivation-builder-arguments
|
||
derivation-builder-environment-vars
|
||
derivation-prerequisites
|
||
derivation-prerequisites-to-build
|
||
|
||
<derivation-output>
|
||
derivation-output?
|
||
derivation-output-path
|
||
derivation-output-hash-algo
|
||
derivation-output-hash
|
||
|
||
<derivation-input>
|
||
derivation-input?
|
||
derivation-input-path
|
||
derivation-input-sub-derivations
|
||
|
||
fixed-output-derivation?
|
||
derivation-hash
|
||
|
||
read-derivation
|
||
write-derivation
|
||
derivation-path->output-path
|
||
derivation
|
||
|
||
%guile-for-build
|
||
build-expression->derivation
|
||
imported-files))
|
||
|
||
;;;
|
||
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
|
||
;;;
|
||
|
||
(define-record-type <derivation>
|
||
(make-derivation outputs inputs sources system builder args env-vars)
|
||
derivation?
|
||
(outputs derivation-outputs) ; list of name/<derivation-output> pairs
|
||
(inputs derivation-inputs) ; list of <derivation-input>
|
||
(sources derivation-sources) ; list of store paths
|
||
(system derivation-system) ; string
|
||
(builder derivation-builder) ; store path
|
||
(args derivation-builder-arguments) ; list of strings
|
||
(env-vars derivation-builder-environment-vars)) ; list of name/value pairs
|
||
|
||
(define-record-type <derivation-output>
|
||
(make-derivation-output path hash-algo hash)
|
||
derivation-output?
|
||
(path derivation-output-path) ; store path
|
||
(hash-algo derivation-output-hash-algo) ; symbol | #f
|
||
(hash derivation-output-hash)) ; bytevector | #f
|
||
|
||
(define-record-type <derivation-input>
|
||
(make-derivation-input path sub-derivations)
|
||
derivation-input?
|
||
(path derivation-input-path) ; store path
|
||
(sub-derivations derivation-input-sub-derivations)) ; list of strings
|
||
|
||
(define (fixed-output-derivation? drv)
|
||
"Return #t if DRV is a fixed-output derivation, such as the result of a
|
||
download with a fixed hash (aka. `fetchurl')."
|
||
(match drv
|
||
(($ <derivation>
|
||
(($ <derivation-output> _ (? symbol?) (? string?))))
|
||
#t)
|
||
(_ #f)))
|
||
|
||
(define (derivation-prerequisites drv)
|
||
"Return the list of derivation-inputs required to build DRV, recursively."
|
||
(let loop ((drv drv)
|
||
(result '()))
|
||
(let ((inputs (remove (cut member <> result) ; XXX: quadratic
|
||
(derivation-inputs drv))))
|
||
(fold loop
|
||
(append inputs result)
|
||
(map (lambda (i)
|
||
(call-with-input-file (derivation-input-path i)
|
||
read-derivation))
|
||
inputs)))))
|
||
|
||
(define (derivation-prerequisites-to-build store drv)
|
||
"Return the list of derivation-inputs required to build DRV and not already
|
||
available in STORE, recursively."
|
||
(define input-built?
|
||
(match-lambda
|
||
(($ <derivation-input> path sub-drvs)
|
||
(let ((out (map (cut derivation-path->output-path path <>)
|
||
sub-drvs)))
|
||
(any (cut valid-path? store <>) out)))))
|
||
|
||
(let loop ((drv drv)
|
||
(result '()))
|
||
(let ((inputs (remove (lambda (i)
|
||
(or (member i result) ; XXX: quadratic
|
||
(input-built? i)))
|
||
(derivation-inputs drv))))
|
||
(fold loop
|
||
(append inputs result)
|
||
(map (lambda (i)
|
||
(call-with-input-file (derivation-input-path i)
|
||
read-derivation))
|
||
inputs)))))
|
||
|
||
(define (read-derivation drv-port)
|
||
"Read the derivation from DRV-PORT and return the corresponding
|
||
<derivation> object."
|
||
|
||
(define comma (string->symbol ","))
|
||
|
||
(define (ununquote x)
|
||
(match x
|
||
(('unquote x) (ununquote x))
|
||
((x ...) (map ununquote x))
|
||
(_ x)))
|
||
|
||
(define (outputs->alist x)
|
||
(fold-right (lambda (output result)
|
||
(match output
|
||
((name path "" "")
|
||
(alist-cons name
|
||
(make-derivation-output path #f #f)
|
||
result))
|
||
((name path hash-algo hash)
|
||
;; fixed-output
|
||
(let ((algo (string->symbol hash-algo))
|
||
(hash (base16-string->bytevector hash)))
|
||
(alist-cons name
|
||
(make-derivation-output path algo hash)
|
||
result)))))
|
||
'()
|
||
x))
|
||
|
||
(define (make-input-drvs x)
|
||
(fold-right (lambda (input result)
|
||
(match input
|
||
((path (sub-drvs ...))
|
||
(cons (make-derivation-input path sub-drvs)
|
||
result))))
|
||
'()
|
||
x))
|
||
|
||
(let loop ((exp (read drv-port))
|
||
(result '()))
|
||
(match exp
|
||
((? eof-object?)
|
||
(let ((result (reverse result)))
|
||
(match result
|
||
(('Derive ((outputs ...) (input-drvs ...)
|
||
(input-srcs ...)
|
||
(? string? system)
|
||
(? string? builder)
|
||
((? string? args) ...)
|
||
((var value) ...)))
|
||
(make-derivation (outputs->alist outputs)
|
||
(make-input-drvs input-drvs)
|
||
input-srcs
|
||
system builder args
|
||
(fold-right alist-cons '() var value)))
|
||
(_
|
||
(error "failed to parse derivation" drv-port result)))))
|
||
((? (cut eq? <> comma))
|
||
(loop (read drv-port) result))
|
||
(_
|
||
(loop (read drv-port)
|
||
(cons (ununquote exp) result))))))
|
||
|
||
(define (write-derivation drv port)
|
||
"Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
|
||
Eelco Dolstra's PhD dissertation for an overview of a previous version of
|
||
that form."
|
||
(define (list->string lst)
|
||
(string-append "[" (string-join lst ",") "]"))
|
||
|
||
(define (write-list lst)
|
||
(display (list->string lst) port))
|
||
|
||
(define (coalesce-duplicate-inputs inputs)
|
||
;; Return a list of inputs, such that when INPUTS contains the same DRV
|
||
;; twice, they are coalesced, with their sub-derivations merged. This is
|
||
;; needed because Nix itself keeps only one of them.
|
||
(fold (lambda (input result)
|
||
(match input
|
||
(($ <derivation-input> path sub-drvs)
|
||
;; XXX: quadratic
|
||
(match (find (match-lambda
|
||
(($ <derivation-input> p s)
|
||
(string=? p path)))
|
||
result)
|
||
(#f
|
||
(cons input result))
|
||
((and dup ($ <derivation-input> _ sub-drvs2))
|
||
;; Merge DUP with INPUT.
|
||
(let ((sub-drvs (delete-duplicates
|
||
(append sub-drvs sub-drvs2))))
|
||
(cons (make-derivation-input path sub-drvs)
|
||
(delq dup result))))))))
|
||
'()
|
||
inputs))
|
||
|
||
;; Note: lists are sorted alphabetically, to conform with the behavior of
|
||
;; C++ `std::map' in Nix itself.
|
||
|
||
(match drv
|
||
(($ <derivation> outputs inputs sources
|
||
system builder args env-vars)
|
||
(display "Derive(" port)
|
||
(write-list (map (match-lambda
|
||
((name . ($ <derivation-output> path hash-algo hash))
|
||
(format #f "(~s,~s,~s,~s)"
|
||
name path
|
||
(or (and=> hash-algo symbol->string) "")
|
||
(or (and=> hash bytevector->base16-string)
|
||
""))))
|
||
(sort outputs
|
||
(lambda (o1 o2)
|
||
(string<? (car o1) (car o2))))))
|
||
(display "," port)
|
||
(write-list (map (match-lambda
|
||
(($ <derivation-input> path sub-drvs)
|
||
(format #f "(~s,~a)" path
|
||
(list->string (map object->string
|
||
(sort sub-drvs string<?))))))
|
||
(sort (coalesce-duplicate-inputs inputs)
|
||
(lambda (i1 i2)
|
||
(string<? (derivation-input-path i1)
|
||
(derivation-input-path i2))))))
|
||
(display "," port)
|
||
(write-list (map object->string (sort sources string<?)))
|
||
(format port ",~s,~s," system builder)
|
||
(write-list (map object->string args))
|
||
(display "," port)
|
||
(write-list (map (match-lambda
|
||
((name . value)
|
||
(format #f "(~s,~s)" name value)))
|
||
(sort env-vars
|
||
(lambda (e1 e2)
|
||
(string<? (car e1) (car e2))))))
|
||
(display ")" port))))
|
||
|
||
(define* (derivation-path->output-path path #:optional (output "out"))
|
||
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
|
||
path of its output OUTPUT."
|
||
(let* ((drv (call-with-input-file path read-derivation))
|
||
(outputs (derivation-outputs drv)))
|
||
(and=> (assoc-ref outputs output) derivation-output-path)))
|
||
|
||
|
||
;;;
|
||
;;; Derivation primitive.
|
||
;;;
|
||
|
||
(define (compressed-hash bv size) ; `compressHash'
|
||
"Given the hash stored in BV, return a compressed version thereof that fits
|
||
in SIZE bytes."
|
||
(define new (make-bytevector size 0))
|
||
(define old-size (bytevector-length bv))
|
||
(let loop ((i 0))
|
||
(if (= i old-size)
|
||
new
|
||
(let* ((j (modulo i size))
|
||
(o (bytevector-u8-ref new j)))
|
||
(bytevector-u8-set! new j
|
||
(logxor o (bytevector-u8-ref bv i)))
|
||
(loop (+ 1 i))))))
|
||
|
||
(define derivation-hash ; `hashDerivationModulo' in derivations.cc
|
||
(memoize
|
||
(lambda (drv)
|
||
"Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
|
||
(match drv
|
||
(($ <derivation> ((_ . ($ <derivation-output> path
|
||
(? symbol? hash-algo) (? bytevector? hash)))))
|
||
;; A fixed-output derivation.
|
||
(sha256
|
||
(string->utf8
|
||
(string-append "fixed:out:" (symbol->string hash-algo)
|
||
":" (bytevector->base16-string hash)
|
||
":" path))))
|
||
(($ <derivation> outputs inputs sources
|
||
system builder args env-vars)
|
||
;; A regular derivation: replace the path of each input with that
|
||
;; input's hash; return the hash of serialization of the resulting
|
||
;; derivation.
|
||
(let* ((inputs (map (match-lambda
|
||
(($ <derivation-input> path sub-drvs)
|
||
(let ((hash (call-with-input-file path
|
||
(compose bytevector->base16-string
|
||
derivation-hash
|
||
read-derivation))))
|
||
(make-derivation-input hash sub-drvs))))
|
||
inputs))
|
||
(drv (make-derivation outputs inputs sources
|
||
system builder args env-vars)))
|
||
(sha256
|
||
(string->utf8 (call-with-output-string
|
||
(cut write-derivation drv <>))))))))))
|
||
|
||
(define (store-path type hash name) ; makeStorePath
|
||
"Return the store path for NAME/HASH/TYPE."
|
||
(let* ((s (string-append type ":sha256:"
|
||
(bytevector->base16-string hash) ":"
|
||
(%store-prefix) ":" name))
|
||
(h (sha256 (string->utf8 s)))
|
||
(c (compressed-hash h 20)))
|
||
(string-append (%store-prefix) "/"
|
||
(bytevector->nix-base32-string c) "-"
|
||
name)))
|
||
|
||
(define (output-path output hash name) ; makeOutputPath
|
||
"Return an output path for OUTPUT (the name of the output as a string) of
|
||
the derivation called NAME with hash HASH."
|
||
(store-path (string-append "output:" output) hash
|
||
(if (string=? output "out")
|
||
name
|
||
(string-append name "-" output))))
|
||
|
||
(define* (derivation store name system builder args env-vars inputs
|
||
#:key (outputs '("out")) hash hash-algo hash-mode)
|
||
"Build a derivation with the given arguments. Return the resulting
|
||
store path and <derivation> object. When HASH, HASH-ALGO, and HASH-MODE
|
||
are given, a fixed-output derivation is created---i.e., one whose result is
|
||
known in advance, such as a file download."
|
||
(define (add-output-paths drv)
|
||
;; Return DRV with an actual store path for each of its output and the
|
||
;; corresponding environment variable.
|
||
(match drv
|
||
(($ <derivation> outputs inputs sources
|
||
system builder args env-vars)
|
||
(let* ((drv-hash (derivation-hash drv))
|
||
(outputs (map (match-lambda
|
||
((output-name . ($ <derivation-output>
|
||
_ algo hash))
|
||
(let ((path (output-path output-name
|
||
drv-hash name)))
|
||
(cons output-name
|
||
(make-derivation-output path algo
|
||
hash)))))
|
||
outputs)))
|
||
(make-derivation outputs inputs sources system builder args
|
||
(map (match-lambda
|
||
((name . value)
|
||
(cons name
|
||
(or (and=> (assoc-ref outputs name)
|
||
derivation-output-path)
|
||
value))))
|
||
env-vars))))))
|
||
|
||
(define (env-vars-with-empty-outputs)
|
||
;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
|
||
;; empty string, even outputs that do not appear in ENV-VARS.
|
||
(let ((e (map (match-lambda
|
||
((name . val)
|
||
(if (member name outputs)
|
||
(cons name "")
|
||
(cons name val))))
|
||
env-vars)))
|
||
(fold (lambda (output-name env-vars)
|
||
(if (assoc output-name env-vars)
|
||
env-vars
|
||
(append env-vars `((,output-name . "")))))
|
||
e
|
||
outputs)))
|
||
|
||
(let* ((outputs (map (lambda (name)
|
||
;; Return outputs with an empty path.
|
||
(cons name
|
||
(make-derivation-output "" hash-algo hash)))
|
||
outputs))
|
||
(inputs (map (match-lambda
|
||
(((? store-path? input))
|
||
(make-derivation-input input '("out")))
|
||
(((? store-path? input) sub-drvs ...)
|
||
(make-derivation-input input sub-drvs))
|
||
((input . _)
|
||
(let ((path (add-to-store store
|
||
(basename input)
|
||
(hash-algo sha256) #t #t
|
||
input)))
|
||
(make-derivation-input path '()))))
|
||
(delete-duplicates inputs)))
|
||
(env-vars (env-vars-with-empty-outputs))
|
||
(drv-masked (make-derivation outputs
|
||
(filter (compose derivation-path?
|
||
derivation-input-path)
|
||
inputs)
|
||
(filter-map (lambda (i)
|
||
(let ((p (derivation-input-path i)))
|
||
(and (not (derivation-path? p))
|
||
p)))
|
||
inputs)
|
||
system builder args env-vars))
|
||
(drv (add-output-paths drv-masked)))
|
||
|
||
;; (write-derivation drv-masked (current-error-port))
|
||
;; (newline (current-error-port))
|
||
(values (add-text-to-store store (string-append name ".drv")
|
||
(call-with-output-string
|
||
(cut write-derivation drv <>))
|
||
(map derivation-input-path
|
||
inputs))
|
||
drv)))
|
||
|
||
|
||
;;;
|
||
;;; Guile-based builders.
|
||
;;;
|
||
|
||
(define %guile-for-build
|
||
;; The derivation of the Guile to be used within the build environment,
|
||
;; when using `build-expression->derivation'.
|
||
(make-parameter (false-if-exception (nixpkgs-derivation "guile"))))
|
||
|
||
(define* (imported-files store files
|
||
#:key (name "file-import") (system (%current-system)))
|
||
"Return a derivation that imports FILES into STORE. FILES must be a list
|
||
of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
|
||
system, imported, and appears under FINAL-PATH in the resulting store path."
|
||
(define (parent-dirs file-name)
|
||
;; Return the list of parent dirs of FILE-NAME, in the order in which an
|
||
;; `mkdir -p' implementation would make them.
|
||
(let ((not-slash (char-set-complement (char-set #\/))))
|
||
(reverse
|
||
(fold (lambda (dir result)
|
||
(match result
|
||
(()
|
||
(list dir))
|
||
((prev _ ...)
|
||
(cons (string-append prev "/" dir)
|
||
result))))
|
||
'()
|
||
(remove (cut string=? <> ".")
|
||
(string-tokenize (dirname file-name) not-slash))))))
|
||
|
||
(let* ((files (map (match-lambda
|
||
((final-path . file-name)
|
||
(list final-path
|
||
(add-to-store store (basename final-path) #t #f
|
||
"sha256" file-name))))
|
||
files))
|
||
(builder
|
||
`(begin
|
||
(mkdir %output) (chdir %output)
|
||
,@(append-map (match-lambda
|
||
((final-path store-path)
|
||
(append (match (parent-dirs final-path)
|
||
(() '())
|
||
((head ... tail)
|
||
(append (map (lambda (d)
|
||
`(false-if-exception
|
||
(mkdir ,d)))
|
||
head)
|
||
`((or (file-exists? ,tail)
|
||
(mkdir ,tail))))))
|
||
`((symlink ,store-path ,final-path)))))
|
||
files))))
|
||
(build-expression->derivation store name (%current-system)
|
||
builder files)))
|
||
|
||
(define* (imported-modules store modules
|
||
#:key (name "module-import")
|
||
(system (%current-system)))
|
||
"Return a derivation that contains the source files of MODULES, a list of
|
||
module names such as `(ice-9 q)'. All of MODULES must be in the current
|
||
search path."
|
||
;; TODO: Determine the closure of MODULES, build the `.go' files,
|
||
;; canonicalize the source files through read/write, etc.
|
||
(let ((files (map (lambda (m)
|
||
(let ((f (string-append
|
||
(string-join (map symbol->string m) "/")
|
||
".scm")))
|
||
(cons f (search-path %load-path f))))
|
||
modules)))
|
||
(imported-files store files #:name name #:system system)))
|
||
|
||
|
||
(define* (build-expression->derivation store name system exp inputs
|
||
#:key (outputs '("out"))
|
||
hash hash-algo
|
||
(modules '()))
|
||
"Return a derivation that executes Scheme expression EXP as a builder for
|
||
derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples;
|
||
when SUB-DRV is omitted, \"out\" is assumed. EXP is evaluated in an
|
||
environment where %OUTPUT is bound to the main output path, %OUTPUTS is bound
|
||
to a list of output/path pairs, and where %BUILD-INPUTS is bound to an alist
|
||
of string/output-path pairs made from INPUTS. The builder terminates by
|
||
passing the result of EXP to `exit'; thus, when EXP returns #f, the build is
|
||
considered to have failed."
|
||
(define guile
|
||
(string-append (derivation-path->output-path (%guile-for-build))
|
||
"/bin/guile"))
|
||
|
||
(define module-form?
|
||
(match-lambda
|
||
(((or 'define-module 'use-modules) _ ...) #t)
|
||
(_ #f)))
|
||
|
||
(let* ((prologue `(begin
|
||
,@(match exp
|
||
((_ ...)
|
||
;; Module forms must appear at the top-level so
|
||
;; that any macros they export can be expanded.
|
||
(filter module-form? exp))
|
||
(_ `(,exp)))
|
||
|
||
(define %output (getenv "out"))
|
||
(define %outputs
|
||
(map (lambda (o)
|
||
(cons o (getenv o)))
|
||
',outputs))
|
||
(define %build-inputs
|
||
',(map (match-lambda
|
||
((name drv . rest)
|
||
(let ((sub (match rest
|
||
(() "out")
|
||
((x) x))))
|
||
(cons name
|
||
(if (derivation-path? drv)
|
||
(derivation-path->output-path drv
|
||
sub)
|
||
drv)))))
|
||
inputs))
|
||
|
||
;; Guile sets it, but remove it to avoid conflicts when
|
||
;; building Guile-using packages.
|
||
(unsetenv "LD_LIBRARY_PATH")))
|
||
(builder (add-text-to-store store
|
||
(string-append name "-guile-builder")
|
||
(string-append
|
||
(object->string prologue)
|
||
(object->string
|
||
`(exit
|
||
,(match exp
|
||
((_ ...)
|
||
(remove module-form? exp))
|
||
(_ `(,exp))))))
|
||
(map second inputs)))
|
||
(mod-drv (if (null? modules)
|
||
#f
|
||
(imported-modules store modules)))
|
||
(mod-dir (and mod-drv
|
||
(derivation-path->output-path mod-drv))))
|
||
(derivation store name system guile
|
||
`("--no-auto-compile"
|
||
,@(if mod-dir `("-L" ,mod-dir) '())
|
||
,builder)
|
||
'(("HOME" . "/homeless"))
|
||
`((,(%guile-for-build))
|
||
(,builder)
|
||
,@(map cdr inputs)
|
||
,@(if mod-drv `((,mod-drv)) '()))
|
||
#:hash hash #:hash-algo hash-algo
|
||
#:outputs outputs)))
|