mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
First stab at the `derivation' primitive.
* guix/store.scm (%store-prefix): New parameter.
(store-path?, derivation-path?): New procedures.
* guix/derivations.scm (write-derivation): Pass SOURCES through
`object->string'.
(compressed-hash, store-path, output-path, derivation): New
procedures.
* tests/derivations.scm (%store): New global variable.
("derivation with no inputs"): New test.
This commit is contained in:
Ludovic Courtès
parent
38b3122afb
commit
26bbbb9520
3 changed files with 161 additions and 9 deletions
|
|
@ -25,6 +25,7 @@ (define-module (guix derivations)
|
|||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix utils)
|
||||
#:export (derivation?
|
||||
derivation-outputs
|
||||
derivation-inputs
|
||||
|
|
@ -46,7 +47,8 @@ (define-module (guix derivations)
|
|||
derivation-hash
|
||||
|
||||
read-derivation
|
||||
write-derivation))
|
||||
write-derivation
|
||||
derivation))
|
||||
|
||||
;;;
|
||||
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
|
||||
|
|
@ -174,7 +176,7 @@ (define (write-list lst)
|
|||
(list->string (map object->string sub-drvs)))))
|
||||
inputs))
|
||||
(display "," port)
|
||||
(write-list sources)
|
||||
(write-list (map object->string sources))
|
||||
(format port ",~s,~s," system builder)
|
||||
(write-list (map object->string args))
|
||||
(display "," port)
|
||||
|
|
@ -184,6 +186,19 @@ (define (write-list lst)
|
|||
env-vars))
|
||||
(display ")" port))))
|
||||
|
||||
(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 drv) ; `hashDerivationModulo' in derivations.cc
|
||||
"Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
|
||||
|
|
@ -196,13 +211,14 @@ (define (derivation-hash drv) ; `hashDerivationModulo' in derivations.cc
|
|||
(string-append "fixed:out:" hash-algo ":" hash ":" path))))
|
||||
(($ <derivation> outputs inputs sources
|
||||
system builder args env-vars)
|
||||
;; A regular derivation: replace that path of each input with that
|
||||
;; inputs hash; return the hash of serialization of the resulting
|
||||
;; 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 derivation-hash
|
||||
(compose bytevector->base16-string
|
||||
derivation-hash
|
||||
read-derivation))))
|
||||
(make-derivation-input hash sub-drvs))))
|
||||
inputs))
|
||||
|
|
@ -212,6 +228,101 @@ (define (derivation-hash drv) ; `hashDerivationModulo' in derivations.cc
|
|||
(string->utf8 (call-with-output-string
|
||||
(cut write-derivation drv <>))))))))
|
||||
|
||||
(define (instantiate server derivation)
|
||||
#f
|
||||
)
|
||||
(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
|
||||
<derivation> object and its store path. 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-right (lambda (output-name env-vars)
|
||||
(if (assoc output-name env-vars)
|
||||
env-vars
|
||||
(alist-cons output-name "" env-vars)))
|
||||
'()
|
||||
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) . 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 '()))))
|
||||
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)))
|
||||
(add-text-to-store store (string-append name ".drv")
|
||||
(call-with-output-string
|
||||
(cut write-derivation drv <>))
|
||||
(map derivation-input-path
|
||||
inputs))))
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ (define-module (guix store)
|
|||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (srfi srfi-39)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:export (nix-server?
|
||||
|
|
@ -36,11 +37,17 @@ (define-module (guix store)
|
|||
nix-protocol-error-message
|
||||
nix-protocol-error-status
|
||||
|
||||
hash-algo
|
||||
|
||||
open-connection
|
||||
set-build-options
|
||||
add-text-to-store
|
||||
add-to-store
|
||||
build-derivations))
|
||||
build-derivations
|
||||
|
||||
%store-prefix
|
||||
store-path?
|
||||
derivation-path?))
|
||||
|
||||
(define %protocol-version #x109)
|
||||
|
||||
|
|
@ -352,3 +359,24 @@ (define-operation (add-to-store (string basename)
|
|||
(define-operation (build-derivations (string-list derivations))
|
||||
"Build DERIVATIONS; return #t on success."
|
||||
boolean)
|
||||
|
||||
|
||||
;;;
|
||||
;;; Store paths.
|
||||
;;;
|
||||
|
||||
(define %store-prefix
|
||||
;; Absolute path to the Nix store.
|
||||
(make-parameter "/nix/store"))
|
||||
|
||||
(define store-path?
|
||||
(let ((store-path-rx
|
||||
(delay (make-regexp
|
||||
(string-append "^.*" (%store-prefix) "/[^-]{32}-(.+)$")))))
|
||||
(lambda (path)
|
||||
"Return #t if PATH is a store path."
|
||||
(not (not (regexp-exec (force store-path-rx) path))))))
|
||||
|
||||
(define (derivation-path? path)
|
||||
"Return #t if PATH is a derivation path."
|
||||
(and (store-path? path) (string-suffix? ".drv" path)))
|
||||
|
|
|
|||
|
|
@ -19,10 +19,14 @@
|
|||
|
||||
(define-module (test-derivations)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix store)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs io ports))
|
||||
|
||||
(define %store
|
||||
(false-if-exception (open-connection)))
|
||||
|
||||
(test-begin "derivations")
|
||||
|
||||
(test-assert "parse & export"
|
||||
|
|
@ -33,6 +37,15 @@ (define-module (test-derivations)
|
|||
(and (equal? b1 b2)
|
||||
(equal? d1 d2))))
|
||||
|
||||
(test-skip (if %store 0 1))
|
||||
|
||||
(test-assert "derivation with no inputs"
|
||||
(let ((builder (add-text-to-store %store "my-builder.sh"
|
||||
"#!/bin/sh\necho hello, world\n"
|
||||
'())))
|
||||
(store-path? (derivation %store "foo" "x86_64-linux" builder
|
||||
'() '(("HOME" . "/homeless")) '()))))
|
||||
|
||||
(test-end)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue