gnu/build/bootloader.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu build bootloader)
  21   #:use-module (srfi srfi-34)
  22   #:use-module (srfi srfi-35)
  23   #:use-module (ice-9 binary-ports)
  24   #:use-module (ice-9 popen)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (ice-9 format)
  28   #:export (write-file-on-device
  29             invoke/quiet))
  30
  31 \f
  32 ;;;
  33 ;;; Writing utils.
  34 ;;;
  35
  36 (define (write-file-on-device file size device offset)
  37   "Write SIZE bytes from FILE to DEVICE starting at OFFSET."
  38   (call-with-input-file file
  39     (lambda (input)
  40       (let ((bv (get-bytevector-n input size)))
  41         (call-with-output-file device
  42           (lambda (output)
  43             (seek output offset SEEK_SET)
  44             (put-bytevector output bv))
  45           #:binary #t)))))
  46
  47 (define-syntax-rule (G_ str) str)                 ;for xgettext
  48
  49 (define (open-pipe-with-stderr program . args)
  50   "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
  51 both its standard output and standard error to the pipe.  Return two value:
  52 the pipe to read PROGRAM's data from, and the PID of the child process running
  53 PROGRAM."
  54   ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
  55   ;; we need to roll our own.
  56   (match (pipe)
  57     ((input .  output)
  58      (match (primitive-fork)
  59        (0
  60         (dynamic-wind
  61           (const #t)
  62           (lambda ()
  63             (close-port input)
  64             (dup2 (fileno output) 1)
  65             (dup2 (fileno output) 2)
  66             (apply execlp program program args))
  67           (lambda ()
  68             (primitive-exit 127))))
  69        (pid
  70         (close-port output)
  71         (values input pid))))))
  72
  73 ;; TODO: Move to (guix build utils) on the next rebuild cycle.
  74 (define (invoke/quiet program . args)
  75   "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
  76 error.  If PROGRAM succeeds, print nothing and return the unspecified value;
  77 otherwise, raise a '&message' error condition that includes the status code
  78 and the output of PROGRAM."
  79   (define-values (pipe pid)
  80     (apply open-pipe-with-stderr program args))
  81
  82   (let loop ((lines '()))
  83     (match (read-line pipe)
  84       ((? eof-object?)
  85        (close-port pipe)
  86        (match (waitpid pid)
  87          ((_ . status)
  88           (unless (zero? status)
  89             (raise (condition
  90                     (&message
  91                      (message (format #f (G_ "'~a~{ ~a~}' exited with status ~a; \
  92 output follows:~%~%~{  ~a~%~}")
  93                                       program args
  94                                       (or (status:exit-val status)
  95                                           status)
  96                                       (reverse lines))))))))))
  97       (line
  98        (loop (cons line lines))))))