Browse Source

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.
gn-latest-20200428
Ludovic Courtès 8 years ago
parent
commit
26bbbb9520
3 changed files with 161 additions and 9 deletions
  1. +119
    -8
      guix/derivations.scm
  2. +29
    -1
      guix/store.scm
  3. +13
    -0
      tests/derivations.scm

+ 119
- 8
guix/derivations.scm View File

@@ -25,6 +25,7 @@
#: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 @@
derivation-hash

read-derivation
write-derivation))
write-derivation
derivation))

;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
@@ -174,7 +176,7 @@ that form."
(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 @@ that form."
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 @@ that form."
(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 @@ that form."
(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))))

+ 29
- 1
guix/store.scm View File

@@ -24,6 +24,7 @@
#: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 @@
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 (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)))

+ 13
- 0
tests/derivations.scm View File

@@ -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 @@
(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…
Cancel
Save