nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

vm: Factorize input conversion. 

* gnu/system/vm.scm (input->name+output): New procedure.
  (expression->derivation-in-linux-vm): Use it for 'input-alist'.
  (qemu-image)[input->name+derivation]: Remove.  Use
  'input->name+output' instead.
master
Ludovic Courtès 2014-04-11 13:48:55 +02:00
parent e1a87b904a
commit ef09fdfb67
1 changed files with 22 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
gnu/system/vm.scm
View File

@ -64,6 +64,26 @@
;;; ;;;
;;; Code: ;;; Code:
(define* (input->name+output tuple #:key (system (%current-system)))
"Return as a monadic value a name/file-name pair corresponding to TUPLE, an
input tuple. The output file name is when building for SYSTEM."
(with-monad %store-monad
(match tuple
((input (? package? package))
(mlet %store-monad ((out (package-file package #:system system)))
(return `(,input . ,out))))
((input (? package? package) sub-drv)
(mlet %store-monad ((out (package-file package
#:output sub-drv
#:system system)))
(return `(,input . ,out))))
((input (? derivation? drv))
(return `(,input . ,(derivation->output-path drv))))
((input (? derivation? drv) sub-drv)
(return `(,input . ,(derivation->output-path drv sub-drv))))
((input (and (? string?) (? store-path?) file))
(return `(,input . ,file))))))
(define* (expression->derivation-in-linux-vm name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
(system (%current-system)) (system (%current-system))
@ -97,23 +117,7 @@ made available under the /xchg CIFS share."
;; `build-expression->derivation'. ;; `build-expression->derivation'.
(define input-alist (define input-alist
(with-monad %store-monad (map input->name+output inputs))
(map (match-lambda
((input (? package? package))
(mlet %store-monad ((out (package-file package #:system system)))
(return `(,input . ,out))))
((input (? package? package) sub-drv)
(mlet %store-monad ((out (package-file package
#:output sub-drv
#:system system)))
(return `(,input . ,out))))
((input (? derivation? drv))
(return `(,input . ,(derivation->output-path drv))))
((input (? derivation? drv) sub-drv)
(return `(,input . ,(derivation->output-path drv sub-drv))))
((input (and (? string?) (? store-path?) file))
(return `(,input . ,file))))
inputs)))
(define builder (define builder
;; Code that launches the VM that evaluates EXP. ;; Code that launches the VM that evaluates EXP.
@ -192,25 +196,9 @@ POPULATE is a list of directives stating directories or symlinks to be created
in the disk image partition. It is evaluated once the image has been in the disk image partition. It is evaluated once the image has been
populated with INPUTS-TO-COPY. It can be used to provide additional files, populated with INPUTS-TO-COPY. It can be used to provide additional files,
such as /etc files." such as /etc files."
(define (input->name+derivation tuple)
(with-monad %store-monad
(match tuple
((name (? package? package))
(mlet %store-monad ((drv (package->derivation package system)))
(return `(,name . ,(derivation->output-path drv)))))
((name (? package? package) sub-drv)
(mlet %store-monad ((drv (package->derivation package system)))
(return `(,name . ,(derivation->output-path drv sub-drv)))))
((name (? derivation? drv))
(return `(,name . ,(derivation->output-path drv))))
((name (? derivation? drv) sub-drv)
(return `(,name . ,(derivation->output-path drv sub-drv))))
((input (and (? string?) (? store-path?) file))
(return `(,input . ,file))))))
(mlet %store-monad (mlet %store-monad
((graph (sequence %store-monad ((graph (sequence %store-monad
(map input->name+derivation inputs-to-copy)))) (map input->name+output inputs-to-copy))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
"qemu-image" "qemu-image"
`(let () `(let ()