me
/
guix
Archived
1
0
Fork 0
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues/pull-requests.
guix/gnu/build/install.scm

160 lines
6.3 KiB
Scheme

;;; 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 (gnu build install)
#:use-module (guix build utils)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (install-grub
populate-root-file-system
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.
Note that the caller must make sure that GRUB.CFG is registered as a GC root
so that the fonts, background images, etc. referred to by GRUB.CFG are not
GC'd."
(let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
(pivot (string-append target ".new")))
(mkdir-p (dirname target))
;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
;; work when /boot is on a separate partition. Do that atomically.
(copy-file grub.cfg pivot)
(rename-file pivot target)
(unless (zero? (system* "grub-install" "--no-floppy"
"--boot-directory"
(string-append mount-point "/boot")
device))
(error "failed to install GRUB"))))
(define (evaluate-populate-directive directive target)
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET."
(let loop ((directive directive))
(catch 'system-error
(lambda ()
(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)))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
(chmod (string-append target name) mode))
((new '-> old)
(let try ()
(catch 'system-error
(lambda ()
(symlink old (string-append target new)))
(lambda args
;; When doing 'guix system init' on the current '/', some
;; symlinks may already exists. Override them.
(if (= EEXIST (system-error-errno args))
(begin
(delete-file (string-append target new))
(try))
(apply throw args))))))))
(lambda args
;; Usually we can only get here when installing to an existing root,
;; as with 'guix system init foo.scm /'.
(format (current-error-port)
"error: failed to evaluate directive: ~s~%"
directive)
(apply throw args)))))
(define (directives store)
"Return a list of directives to populate the root file system that will host
STORE."
`(;; Note: the store's GID is fixed precisely so we can set it here rather
;; than at activation time.
(directory ,store 0 30000 #o1775)
(directory "/etc")
(directory "/var/log") ; for dmd
(directory "/var/guix/gcroots")
(directory "/var/empty") ; for no-login accounts
(directory "/var/db") ; for dhclient, etc.
(directory "/var/run")
(directory "/run")
(directory "/mnt")
(directory "/var/guix/profiles/per-user/root" 0 0)
;; Link to the initial system generation.
("/var/guix/profiles/system" -> "system-1-link")
("/var/guix/gcroots/booted-system" -> "/run/booted-system")
("/var/guix/gcroots/current-system" -> "/run/current-system")
(directory "/bin")
(directory "/tmp" 0 0 #o1777) ; sticky bit
(directory "/root" 0 0) ; an exception
(directory "/home" 0 0)))
(define (populate-root-file-system system target)
"Make the essential non-store files and directories on TARGET. This
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
(for-each (cut evaluate-populate-directive <> target)
(directives (%store-directory)))
;; Add system generation 1.
(false-if-exception (delete-file "/var/guix/profiles/system-1-link"))
(symlink system
(string-append target "/var/guix/profiles/system-1-link")))
(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'. As a side effect, this resets timestamps on store files."
(let ((status (system* "guix-register" "--prefix" store
closure)))
(unless (zero? status)
(error "failed to register store items" closure))))
;;; install.scm ends here