;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 system bootloader)
  #:use-module (gnu system)
  #:use-module (gnu system grub)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-type
            bootloader-configuration-device
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-file-location
            bootloader-configuration-file-procedure
            bootloader-configuration-install-procedure
            bootloader-configuration-additional-configuration

            %extlinux-configuration
            %grub-configuration
            %grub-efi-configuration
            %syslinux-configuration

            lookup-bootloader-configuration

            extlinux-configuration
            grub-configuration
            grub-efi-configuration
            syslinux-configuration

            dd
            install-grub
            install-syslinux))

;;; Commentary:
;;;
;;; Generic configuration for bootloaders.
;;;
;;; Code:

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader                      bootloader-configuration-bootloader     ; package
                                   (default #f))
  (type                            bootloader-configuration-type
                                   (default #f))                           ; symbol
  (device                          bootloader-configuration-device         ; string
                                   (default #f))
  (menu-entries                    bootloader-configuration-menu-entries   ; list of <boot-parameters>
                                   (default '()))
  (default-entry                   bootloader-configuration-default-entry  ; integer
                                   (default 0))
  (timeout                         bootloader-configuration-timeout        ; integer
                                   (default 5))
  (configuration-file-location     bootloader-configuration-file-location
                                   (default #f))
  (configuration-file-procedure    bootloader-configuration-file-procedure ; procedure
                                   (default #f))
  (install-procedure               bootloader-configuration-install-procedure ; procedure
                                   (default #f))
  (additional-configuration        bootloader-configuration-additional-configuration ; record
                                   (default #f)))

\f

;;;
;;; Extlinux configuration file.
;;;

(define* (extlinux-configuration-file config entries
                                      #:key
                                      (system (%current-system))
                                      (old-entries '()))
  "Return the U-Boot configuration file corresponding to CONFIG, a
<u-boot-configuration> object, and where the store is available at STORE-FS, a
<file-system> object.  OLD-ENTRIES is taken to be a list of menu entries
corresponding to old generations of the system."

  (define all-entries
    (append entries (bootloader-configuration-menu-entries config)))

  (define boot-parameters->gexp
    (match-lambda
      (($ <boot-parameters> label _ _ _ kernel kernel-arguments initrd)
       #~(format port "LABEL ~a
  MENU LABEL ~a
  KERNEL ~a
  FDTDIR ~a/lib/dtbs
  INITRD ~a
  APPEND ~a
~%"
                 #$label #$label
                 #$kernel #$kernel #$initrd
                 (string-join (list #$@kernel-arguments))))))

  (define builder
    #~(call-with-output-file #$output
        (lambda (port)
          (let ((timeout #$(bootloader-configuration-timeout config)))
            (format port "
UI menu.c32
PROMPT ~a
TIMEOUT ~a~%"
                    (if (> timeout 0) 1 0)
                    (* 10 timeout))
            #$@(map boot-parameters->gexp all-entries)

            #$@(if (pair? old-entries)
                   #~((format port "~%")
                      #$@(map boot-parameters->gexp old-entries)
                      (format port "~%"))
                   #~())))))

  (gexp->derivation "extlinux.conf" builder))


\f

;;;
;;; Bootloader install procedures.
;;;

(define dd
  #~(lambda (bs count if of)
      (zero? (system* "dd"
                      (string-append "bs=" (number->string bs))
                      (string-append "count=" (number->string count))
                      (string-append "if=" if)
                      (string-append "of=" of)))))

(define install-grub
  #~(lambda (bootloader device mount-point)
      ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT.
      (let ((grub (string-append bootloader "/sbin/grub-install"))
            (install-dir (string-append mount-point "/boot")))
        ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
        ;; root partition.
        (setenv "GRUB_ENABLE_CRYPTODISK" "y")

        (unless (zero? (system* grub "--no-floppy"
                                "--boot-directory" install-dir
                                device))
          (error "failed to install GRUB")))))

(define install-syslinux
  #~(lambda (bootloader device mount-point)
      (let ((extlinux (string-append bootloader "/sbin/extlinux"))
            (install-dir (string-append mount-point "/boot/extlinux"))
            (syslinux-dir (string-append bootloader "/share/syslinux")))
        (mkdir-p install-dir)
        (for-each (lambda (file)
                    (copy-file file
                               (string-append install-dir "/" (basename file))))
                  (find-files syslinux-dir "\\.c32$"))

        (unless (and (zero? (system* extlinux "--install" install-dir))
                     (#$dd 440 1 (string-append syslinux-dir "/mbr.bin") device))
          (error "failed to install SYSLINUX")))))


;;;
;;; Bootloader configurations.
;;;

(define* %extlinux-configuration
  (bootloader-configuration
   (type 'extlinux)
   (configuration-file-location "/boot/extlinux/extlinux.conf")
   (configuration-file-procedure extlinux-configuration-file)))

(define* %grub-configuration
  (bootloader-configuration
   (type 'grub)
   (bootloader (@ (gnu packages bootloaders) grub))
   (configuration-file-location "/boot/grub/grub.cfg")
   (configuration-file-procedure grub-configuration-file)
   (install-procedure install-grub)
   (additional-configuration %default-theme)))

(define* %grub-efi-configuration
  (bootloader-configuration
   (inherit %grub-configuration)
   (type 'grub-efi)
   (bootloader (@ (gnu packages bootloaders) grub-efi))))

(define* %syslinux-configuration
  (bootloader-configuration
   (inherit %extlinux-configuration)
   (type 'syslinux)
   (bootloader (@ (gnu packages bootloaders) syslinux))
   (install-procedure install-syslinux)))

(define %bootloader-configurations
  (list %extlinux-configuration
        %grub-configuration
        %grub-efi-configuration
        %syslinux-configuration))

(define (lookup-bootloader-configuration type)
  (or (find (lambda (conf)
              (eq? (bootloader-configuration-type conf)
                   type))
            %bootloader-configurations)
      (error "~a: unknown bootloader type" type)))

;;;
;;; Compatibility macros.
;;;

(define-syntax-rule (extlinux-configuration fields ...)
  (bootloader-configuration
   (inherit %extlinux-configuration)
   fields ...))

(define-syntax-rule (grub-configuration fields ...)
  (bootloader-configuration
   (inherit %grub-configuration)
   fields ...))

(define-syntax-rule (grub-efi-configuration fields ...)
  (bootloader-configuration
   (inherit %grub-efi-configuration)
   fields ...))

(define-syntax-rule (syslinux-configuration fields ...)
  (bootloader-configuration
   (inherit %syslinux-configuration)
   fields ...))

;;; bootloader.scm ends here