system: Add (guix build install) module.
* guix/build/vm.scm (install-grub, evaluate-populate-directive, reset-timestamps, register-closure): Move to... * guix/build/install.scm: ... here. New file. * Makefile.am (MODULES): Add it. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add (guix build install) to #:modules.
This commit is contained in:
Ludovic Courtès
parent
150e20ddde
commit
5ce3defed1
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue