You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

404 lines
16 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013 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. (define-module (gnu packages linux-initrd)
  19. #:use-module (guix utils)
  20. #:use-module (guix licenses)
  21. #:use-module (guix build-system)
  22. #:use-module ((guix derivations)
  23. #:select (imported-modules compiled-modules %guile-for-build))
  24. #:use-module (gnu packages)
  25. #:use-module (gnu packages cpio)
  26. #:use-module (gnu packages compression)
  27. #:use-module (gnu packages linux)
  28. #:use-module (gnu packages guile)
  29. #:use-module ((gnu packages make-bootstrap)
  30. #:select (%guile-static-stripped))
  31. #:use-module (guix packages)
  32. #:use-module (guix download)
  33. #:use-module (guix build-system trivial))
  34. ;;; Commentary:
  35. ;;;
  36. ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
  37. ;;; particular initrd's that run Guile.
  38. ;;;
  39. ;;; Code:
  40. (define-syntax-rule (raw-build-system (store system name inputs) body ...)
  41. "Lift BODY to a package build system."
  42. ;; TODO: Generalize.
  43. (build-system
  44. (name "raw")
  45. (description "Raw build system")
  46. (build (lambda* (store name source inputs #:key system #:allow-other-keys)
  47. (parameterize ((%guile-for-build (package-derivation store
  48. guile-2.0)))
  49. body ...)))))
  50. (define (module-package modules)
  51. "Return a package that contains all of MODULES, a list of Guile module
  52. names."
  53. (package
  54. (name "guile-modules")
  55. (version "0")
  56. (source #f)
  57. (build-system (raw-build-system (store system name inputs)
  58. (imported-modules store modules
  59. #:name name
  60. #:system system)))
  61. (synopsis "Set of Guile modules")
  62. (description synopsis)
  63. (license gpl3+)
  64. (home-page "http://www.gnu.org/software/guix/")))
  65. (define (compiled-module-package modules)
  66. "Return a package that contains the .go files corresponding to MODULES, a
  67. list of Guile module names."
  68. (package
  69. (name "guile-compiled-modules")
  70. (version "0")
  71. (source #f)
  72. (build-system (raw-build-system (store system name inputs)
  73. (compiled-modules store modules
  74. #:name name
  75. #:system system)))
  76. (synopsis "Set of compiled Guile modules")
  77. (description synopsis)
  78. (license gpl3+)
  79. (home-page "http://www.gnu.org/software/guix/")))
  80. (define* (expression->initrd exp
  81. #:key
  82. (guile %guile-static-stripped)
  83. (cpio cpio)
  84. (gzip gzip)
  85. (name "guile-initrd")
  86. (system (%current-system))
  87. (modules '())
  88. (linux #f)
  89. (linux-modules '()))
  90. "Return a package that contains a Linux initrd (a gzipped cpio archive)
  91. containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list
  92. of `.ko' file names to be copied from LINUX into the initrd. MODULES is a
  93. list of Guile module names to be embedded in the initrd."
  94. ;; General Linux overview in `Documentation/early-userspace/README' and
  95. ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
  96. (define builder
  97. `(begin
  98. (use-modules (guix build utils)
  99. (ice-9 pretty-print)
  100. (ice-9 popen)
  101. (ice-9 match)
  102. (ice-9 ftw)
  103. (srfi srfi-26)
  104. (system base compile)
  105. (rnrs bytevectors)
  106. ((system foreign) #:select (sizeof)))
  107. (let ((guile (assoc-ref %build-inputs "guile"))
  108. (cpio (string-append (assoc-ref %build-inputs "cpio")
  109. "/bin/cpio"))
  110. (gzip (string-append (assoc-ref %build-inputs "gzip")
  111. "/bin/gzip"))
  112. (modules (assoc-ref %build-inputs "modules"))
  113. (gos (assoc-ref %build-inputs "modules/compiled"))
  114. (scm-dir (string-append "share/guile/" (effective-version)))
  115. (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a"
  116. (effective-version)
  117. (if (eq? (native-endianness) (endianness little))
  118. "LE"
  119. "BE")
  120. (sizeof '*)
  121. (effective-version)))
  122. (out (assoc-ref %outputs "out")))
  123. (mkdir out)
  124. (mkdir "contents")
  125. (with-directory-excursion "contents"
  126. (copy-recursively guile ".")
  127. (call-with-output-file "init"
  128. (lambda (p)
  129. (format p "#!/bin/guile -ds~%!#~%" guile)
  130. (pretty-print ',exp p)))
  131. (chmod "init" #o555)
  132. (chmod "bin/guile" #o555)
  133. ;; Copy Guile modules.
  134. (chmod scm-dir #o777)
  135. (copy-recursively modules scm-dir
  136. #:follow-symlinks? #t)
  137. (copy-recursively gos (string-append "lib/guile/"
  138. (effective-version) "/ccache")
  139. #:follow-symlinks? #t)
  140. ;; Compile `init'.
  141. (mkdir-p go-dir)
  142. (set! %load-path (cons modules %load-path))
  143. (set! %load-compiled-path (cons gos %load-compiled-path))
  144. (compile-file "init"
  145. #:opts %auto-compilation-options
  146. #:output-file (string-append go-dir "/init.go"))
  147. ;; Copy Linux modules.
  148. (let* ((linux (assoc-ref %build-inputs "linux"))
  149. (module-dir (and linux
  150. (string-append linux "/lib/modules"))))
  151. (mkdir "modules")
  152. ,@(map (lambda (module)
  153. `(match (find-files module-dir ,module)
  154. ((file)
  155. (format #t "copying '~a'...~%" file)
  156. (copy-file file (string-append "modules/"
  157. ,module)))
  158. (()
  159. (error "module not found" ,module module-dir))
  160. ((_ ...)
  161. (error "several modules by that name"
  162. ,module module-dir))))
  163. linux-modules))
  164. ;; Reset the timestamps of all the files that will make it in the
  165. ;; initrd.
  166. (for-each (cut utime <> 0 0 0 0)
  167. (find-files "." ".*"))
  168. (system* cpio "--version")
  169. (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
  170. "-O" (string-append out "/initrd")
  171. "-H" "newc" "--null")))
  172. (define print0
  173. (let ((len (string-length "./")))
  174. (lambda (file)
  175. (format pipe "~a\0" (string-drop file len)))))
  176. ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
  177. ;; directory entries before the files that are inside of it: "The
  178. ;; Linux kernel cpio extractor won't create files in a directory
  179. ;; that doesn't exist, so the directory entries must go before
  180. ;; the files that go in those directories."
  181. (file-system-fold (const #t)
  182. (lambda (file stat result) ; leaf
  183. (print0 file))
  184. (lambda (dir stat result) ; down
  185. (unless (string=? dir ".")
  186. (print0 dir)))
  187. (const #f) ; up
  188. (const #f) ; skip
  189. (const #f)
  190. #f
  191. ".")
  192. (and (zero? (close-pipe pipe))
  193. (with-directory-excursion out
  194. (and (zero? (system* gzip "--best" "initrd"))
  195. (rename-file "initrd.gz" "initrd")))))))))
  196. (package
  197. (name name)
  198. (version "0")
  199. (source #f)
  200. (build-system trivial-build-system)
  201. (arguments `(#:modules ((guix build utils))
  202. #:builder ,builder))
  203. (inputs `(("guile" ,guile)
  204. ("cpio" ,cpio)
  205. ("gzip" ,gzip)
  206. ("modules" ,(module-package modules))
  207. ("modules/compiled" ,(compiled-module-package modules))
  208. ,@(if linux
  209. `(("linux" ,linux))
  210. '())))
  211. (synopsis "An initial RAM disk (initrd) for the Linux kernel")
  212. (description
  213. "An initial RAM disk (initrd), really a gzipped cpio archive, for use by
  214. the Linux kernel.")
  215. (license gpl3+)
  216. (home-page "http://www.gnu.org/software/guix/")))
  217. (define-public qemu-initrd
  218. (expression->initrd
  219. '(begin
  220. (use-modules (srfi srfi-1)
  221. (srfi srfi-26)
  222. (ice-9 match)
  223. ((system base compile) #:select (compile-file))
  224. (guix build utils)
  225. (guix build linux-initrd))
  226. (display "Welcome, this is GNU's early boot Guile.\n")
  227. (display "Use '--repl' for an initrd REPL.\n\n")
  228. (mount-essential-file-systems)
  229. (let* ((args (linux-command-line))
  230. (option (lambda (opt)
  231. (let ((opt (string-append opt "=")))
  232. (and=> (find (cut string-prefix? opt <>)
  233. args)
  234. (lambda (arg)
  235. (substring arg (+ 1 (string-index arg #\=))))))))
  236. (to-load (option "--load"))
  237. (root (option "--root")))
  238. (when (member "--repl" args)
  239. ((@ (system repl repl) start-repl)))
  240. (display "loading CIFS and companion modules...\n")
  241. (for-each (compose load-linux-module*
  242. (cut string-append "/modules/" <>))
  243. (list "md4.ko" "ecb.ko" "cifs.ko"))
  244. (unless (configure-qemu-networking)
  245. (display "network interface is DOWN\n"))
  246. ;; Make /dev nodes.
  247. (make-essential-device-nodes)
  248. ;; Prepare the real root file system under /root.
  249. (unless (file-exists? "/root")
  250. (mkdir "/root"))
  251. (if root
  252. (mount root "/root" "ext3")
  253. (mount "none" "/root" "tmpfs"))
  254. (mount-essential-file-systems #:root "/root")
  255. (mkdir "/root/xchg")
  256. (mkdir-p "/root/nix/store")
  257. (unless (file-exists? "/root/dev")
  258. (mkdir "/root/dev")
  259. (make-essential-device-nodes #:root "/root"))
  260. ;; Mount the host's store and exchange directory.
  261. (mount-qemu-smb-share "/store" "/root/nix/store")
  262. (mount-qemu-smb-share "/xchg" "/root/xchg")
  263. ;; Copy the directories that contain .scm and .go files so that the
  264. ;; child process in the chroot can load modules (we would bind-mount
  265. ;; them but for some reason that fails with EINVAL -- XXX).
  266. (mkdir "/root/share")
  267. (mkdir "/root/lib")
  268. (mount "none" "/root/share" "tmpfs")
  269. (mount "none" "/root/lib" "tmpfs")
  270. (copy-recursively "/share" "/root/share"
  271. #:log (%make-void-port "w"))
  272. (copy-recursively "/lib" "/root/lib"
  273. #:log (%make-void-port "w"))
  274. (if to-load
  275. (begin
  276. (format #t "loading boot file '~a'...\n" to-load)
  277. (compile-file (string-append "/root/" to-load)
  278. #:output-file "/root/loader.go"
  279. #:opts %auto-compilation-options)
  280. (match (primitive-fork)
  281. (0
  282. (chroot "/root")
  283. (load-compiled "/loader.go")
  284. ;; TODO: Remove /lib, /share, and /loader.go.
  285. )
  286. (pid
  287. (format #t "boot file loaded under PID ~a~%" pid)
  288. (let ((status (waitpid pid)))
  289. (reboot)))))
  290. (begin
  291. (display "no boot file passed via '--load'\n")
  292. (display "entering a warm and cozy REPL\n")
  293. ((@ (system repl repl) start-repl))))))
  294. #:name "qemu-initrd"
  295. #:modules '((guix build utils)
  296. (guix build linux-initrd))
  297. #:linux linux-libre
  298. #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
  299. (define-public gnu-system-initrd
  300. ;; Initrd for the GNU system itself, with nothing QEMU-specific.
  301. (expression->initrd
  302. '(begin
  303. (use-modules (srfi srfi-1)
  304. (srfi srfi-26)
  305. (ice-9 match)
  306. (guix build utils)
  307. (guix build linux-initrd))
  308. (display "Welcome, this is GNU's early boot Guile.\n")
  309. (display "Use '--repl' for an initrd REPL.\n\n")
  310. (mount-essential-file-systems)
  311. (let* ((args (linux-command-line))
  312. (option (lambda (opt)
  313. (let ((opt (string-append opt "=")))
  314. (and=> (find (cut string-prefix? opt <>)
  315. args)
  316. (lambda (arg)
  317. (substring arg (+ 1 (string-index arg #\=))))))))
  318. (to-load (option "--load"))
  319. (root (option "--root")))
  320. (when (member "--repl" args)
  321. ((@ (system repl repl) start-repl)))
  322. ;; Make /dev nodes.
  323. (make-essential-device-nodes)
  324. ;; Prepare the real root file system under /root.
  325. (mkdir-p "/root")
  326. (if root
  327. ;; Assume ROOT has a usable /dev tree.
  328. (mount root "/root" "ext3")
  329. (begin
  330. (mount "none" "/root" "tmpfs")
  331. (make-essential-device-nodes #:root "/root")))
  332. (mount-essential-file-systems #:root "/root")
  333. (mkdir-p "/root/tmp")
  334. (mount "none" "/root/tmp" "tmpfs")
  335. ;; XXX: We don't copy our fellow Guile modules to /root (see
  336. ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
  337. ;; happen if it throws, to display the exception!), then we're
  338. ;; screwed. Hopefully TO-LOAD is a simple expression that just does
  339. ;; '(execlp ...)'.
  340. (if to-load
  341. (begin
  342. (format #t "loading '~a'...\n" to-load)
  343. (chroot "/root")
  344. (primitive-load to-load)
  345. (format (current-error-port)
  346. "boot program '~a' terminated, rebooting~%"
  347. to-load)
  348. (sleep 2)
  349. (reboot))
  350. (begin
  351. (display "no init file passed via '--exec'\n")
  352. (display "entering a warm and cozy REPL\n")
  353. ((@ (system repl repl) start-repl))))))
  354. #:name "qemu-system-initrd"
  355. #:modules '((guix build linux-initrd)
  356. (guix build utils))
  357. #:linux linux-libre))
  358. ;;; linux-initrd.scm ends here