gnu/system/hurd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu system hurd)
  20   #:use-module (guix gexp)
  21   #:use-module (guix utils)
  22   #:use-module (gnu bootloader grub)
  23   #:use-module (gnu packages base)
  24   #:use-module (gnu packages bash)
  25   #:use-module (gnu packages cross-base)
  26   #:use-module (gnu packages hurd)
  27   #:use-module (gnu system vm)
  28   #:export (cross-hurd-image))
  29
  30 ;;; Commentary:
  31 ;;;
  32 ;;; This module provides tools to (cross-)build GNU/Hurd virtual machine
  33 ;;; images.
  34 ;;;
  35 ;;; Code:
  36
  37 (define* (cross-hurd-image #:key (hurd hurd) (gnumach gnumach))
  38   "Return a cross-built GNU/Hurd image."
  39   (define hurd-os
  40     (let-syntax ((for-hurd (syntax-rules ()
  41                              ((_ things ...)
  42                               (list (with-parameters ((%current-target-system
  43                                                        "i586-pc-gnu"))
  44                                       things) ...)))))
  45       (directory-union "gnu+hurd"
  46                        (cons (with-parameters ((%current-system "i686-linux"))
  47                                gnumach)
  48                              (for-hurd hurd bash coreutils grep sed)))))
  49
  50   (define grub.cfg
  51     (let ((hurd (with-parameters ((%current-target-system "i586-pc-gnu"))
  52                   hurd))
  53           (mach (with-parameters ((%current-system "i686-linux"))
  54                   gnumach))
  55           (libc (cross-libc "i586-pc-gnu")))
  56       (computed-file "grub.cfg"
  57                      #~(call-with-output-file #$output
  58                          (lambda (port)
  59                            (format port "
  60 set timeout=2
  61 search.file ~a/boot/gnumach
  62
  63 menuentry \"GNU\" {
  64   multiboot ~a/boot/gnumach root=device:hd0s1
  65   module ~a/hurd/ext2fs.static ext2fs \\
  66     --multiboot-command-line='${kernel-command-line}' \\
  67     --host-priv-port='${host-port}' \\
  68     --device-master-port='${device-port}' \\
  69     --exec-server-task='${exec-task}' -T typed '${root}' \\
  70     '$(task-create)' '$(task-resume)'
  71   module ~a/lib/ld.so.1 exec ~a/hurd/exec '$(exec-task=task-create)'
  72 }\n"
  73                                    #+mach #+mach #+hurd
  74                                    #+libc #+hurd))))))
  75
  76   (define fstab
  77     (plain-file "fstab"
  78 "# This file was generated from your Guix configuration.  Any changes
  79 # will be lost upon reboot or reconfiguration.
  80
  81 /dev/hd0s1      /       ext2    defaults
  82 "))
  83
  84   (define passwd
  85     (plain-file "passwd"
  86 "root:x:0:0:root:/root:/bin/sh
  87 "
  88 ))
  89
  90   (define shadow
  91     (plain-file "shadow"
  92 "root::0:0:0:0:::
  93 "
  94 ))
  95
  96   (define hurd-directives
  97     `((directory "/servers")
  98       ,@(map (lambda (server)
  99                `(file ,(string-append "/servers/" server)))
 100              '("startup" "exec" "proc" "password"
 101                "default-pager" "crash-dump-core"
 102                "kill" "suspend"))
 103       ("/servers/crash" -> "crash-dump-core")
 104       (directory "/servers/socket")
 105       (file "/servers/socket/1")
 106       (file "/servers/socket/2")
 107       (file "/servers/socket/16")
 108       ("/servers/socket/local" -> "1")
 109       ("/servers/socket/inet" -> "2")
 110       ("/servers/socket/inet6" -> "16")
 111       (file "/etc/resolv.conf"
 112             "nameserver 10.0.2.3\n")
 113       (directory "/boot")
 114       ("/boot/grub.cfg" -> ,grub.cfg)  ;XXX: not strictly needed
 115       ("/hurd" -> ,(file-append (with-parameters ((%current-target-system
 116                                                    "i586-pc-gnu"))
 117                                   hurd)
 118                                 "/hurd"))
 119       ("/etc/fstab" -> ,fstab)
 120       ("/etc/passwd" -> ,passwd)
 121       ("/etc/shadow" -> ,shadow)
 122       ;; XXX can we instead, harmlessly set _PATH_TTYS (from glibc) in runttys.c?
 123       ("/etc/ttys" -> ,(file-append (with-parameters ((%current-target-system
 124                                                    "i586-pc-gnu"))
 125                                   hurd)
 126                                 "/etc/ttys"))
 127       ("/bin/sh" -> ,(file-append (with-parameters ((%current-target-system
 128                                                      "i586-pc-gnu"))
 129                                     bash)
 130                                   "/bin/sh"))))
 131
 132   (qemu-image #:file-system-type "ext2"
 133               #:file-system-options '("-o" "hurd")
 134               #:device-nodes 'hurd
 135               #:inputs `(("system" ,hurd-os)
 136                          ("grub.cfg" ,grub.cfg)
 137                          ("fstab" ,fstab)
 138                          ("passwd" ,passwd)
 139                          ("shadow" ,shadow))
 140               #:copy-inputs? #t
 141               #:os hurd-os
 142               #:bootcfg-drv grub.cfg
 143               #:bootloader grub-bootloader
 144               #:register-closures? #f
 145               #:extra-directives hurd-directives))
 146
 147 ;; Return this thunk so one can type "guix build -f gnu/system/hurd.scm".
 148 cross-hurd-image