guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
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.
version-0.8.3
Ludovic Courtès 10 years ago
parent
38b3122afb
commit
26bbbb9520
3 changed files with 161 additions and 9 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 127
      guix/derivations.scm
  2. 30
      guix/store.scm
  3. 13
      tests/derivations.scm

127
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))))

30
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
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)

Write Preview
Loading…
Cancel
Save