diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 5 | ||||
| -rw-r--r-- | guix/build/install.scm | 82 | ||||
| -rw-r--r-- | guix/build/vm.scm | 46 |
4 files changed, 86 insertions, 48 deletions
diff --git a/Makefile.am b/Makefile.am index 20bf650c9b..a08215ef1e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -70,6 +70,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/install.scm \ guix/build/activation.scm \ guix/build/syscalls.scm \ guix/packages.scm \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7008c5dab2..58e5416b3e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -109,6 +109,7 @@ input tuple. The output file name is when building for SYSTEM." (env-vars '()) (modules '((guix build vm) + (guix build install) (guix build linux-initrd) (guix build utils))) (guile-for-build @@ -179,9 +180,7 @@ made available under the /xchg CIFS share." ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars - #:modules `((guix build utils) - (guix build vm) - (guix build linux-initrd)) + #:modules modules #:guile-for-build guile-for-build #:references-graphs references-graphs))) diff --git a/guix/build/install.scm b/guix/build/install.scm new file mode 100644 index 0000000000..37153703e5 --- /dev/null +++ b/guix/build/install.scm @@ -0,0 +1,82 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU 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. +;;; +;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build install) + #:use-module (guix build utils) + #:use-module (guix build install) + #:use-module (ice-9 match) + #:export (install-grub + evaluate-populate-directive + reset-timestamps + register-closure)) + +;;; Commentary: +;;; +;;; This module supports the installation of the GNU system on a hard disk. +;;; It is meant to be used both in a build environment (in derivations that +;;; build VM images), and on the bare metal (when really installing the +;;; system.) +;;; +;;; Code: + +(define* (install-grub grub.cfg device mount-point) + "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on +MOUNT-POINT. Return #t on success." + (mkdir-p (string-append mount-point "/boot/grub")) + (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) + (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" (string-append mount-point "/boot") + device))) + +(define (evaluate-populate-directive directive target) + "Evaluate DIRECTIVE, an sexp describing a file or directory to create under +directory TARGET." + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + ((new '-> old) + (symlink old (string-append target new))))) + +(define (reset-timestamps directory) + "Reset the timestamps of all the files under DIRECTORY, so that they appear +as created and modified at the Epoch." + (display "clearing file timestamps...\n") + (for-each (lambda (file) + (let ((s (lstat file))) + ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so + ;; the timestamp of symlinks cannot be changed, and there are + ;; symlinks here pointing to /gnu/store, which is the host, + ;; read-only store. + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files directory ""))) + +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +;;; install.scm ends here diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2c13a8904b..12f952bd11 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -19,6 +19,7 @@ (define-module (guix build vm) #:use-module (guix build utils) #:use-module (guix build linux-initrd) + #:use-module (guix build install) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) @@ -124,15 +125,6 @@ partition of PARTITION-SIZE MiB. Return #t on success." "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) -(define* (install-grub grub.cfg device mount-point) - "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) - (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." @@ -153,42 +145,6 @@ REFERENCE-GRAPHS, a list of reference-graph files." (string-append target thing))) (things-to-copy))) -(define (evaluate-populate-directive directive target) - "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) - -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so - ;; the timestamp of symlinks cannot be changed, and there are - ;; symlinks here pointing to /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory ""))) - -(define (register-closure store closure) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'." - (let ((status (system* "guix-register" "--prefix" store - closure))) - (unless (zero? status) - (error "failed to register store items" closure)))) - (define MS_BIND 4096) ; <sys/mounts.h> again! (define* (initialize-hard-disk #:key |