;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;;
;;; 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 (ice-9 match)
  #:export (bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            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))

;;; 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))
  (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)))



;;;
;;; 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))




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

(define* (extlinux-configuration #:optional (config (bootloader-configuration)))
  (bootloader-configuration
   (inherit config)
   (configuration-file-location "/boot/extlinux/extlinux.conf")
   (configuration-file-procedure extlinux-configuration-file)))

(define* (grub-configuration #:optional (config (bootloader-configuration)))
  (bootloader-configuration
   (inherit config)
   (bootloader (@ (gnu packages bootloaders) grub))
   (configuration-file-location "/boot/grub/grub.cfg")
   (configuration-file-procedure grub-configuration-file)
   (install-procedure install-grub)
   (additional-configuration
    (let ((additional-config (bootloader-configuration-additional-configuration config)))
      (if additional-config additional-config %default-theme)))))

(define* (grub-efi-configuration #:optional (config (bootloader-configuration)))
  (bootloader-configuration
   (inherit (grub-configuration config))
   (bootloader (@ (gnu packages bootloaders) grub-efi))))

(define* (syslinux-configuration #:optional (config (bootloader-configuration)))
  (bootloader-configuration
   (inherit (extlinux-configuration config))
   (bootloader (@ (gnu packages bootloaders) syslinux))
   (install-procedure install-syslinux)))

;;; bootloader.scm ends here