code:
#!/bin/bash
# GNU Guix --- Functional package management for GNU
# Copyright © 2017 sharlatan <sharlatanus@gmail.com>
# Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
# Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
#
# 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/>.

set -e

[ "$UID" -eq 0 ] || { echo "This script must be run as root."; exit 1; }

REQUIRE=(
    "dirname"
    "readlink"
    "wget"
    "gpg"
    "grep"
    "which"
    "sed"
    "sort"
    "getent"
    "mktemp"
    "rm"
    "chmod"
    "uname"
    "groupadd"
    "tail"
    "tr"
)

PAS=$'[ \033[32;1mPASS\033[0m ] '
ERR=$'[ \033[31;1mFAIL\033[0m ] '
INF="[ INFO ] "

DEBUG=0
GNU_URL="https://alpha.gnu.org/gnu/guix/"
OPENPGP_SIGNING_KEY_ID="3CE464558A84FDC69DB40CFB090B11993D9AEBB5"

# This script needs to know where root's home directory is.  However, we
# cannot simply use the HOME environment variable, since there is no guarantee
# that it points to root's home directory.
ROOT_HOME="$(echo ~root)"

# ------------------------------------------------------------------------------
#+UTILITIES

_err()
{ # All errors go to stderr.
    printf "[%s]: %s\n" "$(date +%s.%3N)" "$1"
}

_msg()
{ # Default message to stdout.
    printf "[%s]: %s\n" "$(date +%s.%3N)" "$1"
}

_debug()
{
    if [ "${DEBUG}" = '1' ]; then
        printf "[%s]: %s\n" "$(date +%s.%3N)" "$1"
    fi
}

chk_require()
{ # Check that every required command is available.
    declare -a cmds
    declare -a warn

    cmds=(${1})

    _debug "--- [ $FUNCNAME ] ---"

    for c in ${cmds[@]}; do
        command -v "$c" &>/dev/null || warn+=("$c")
    done

    [ "${#warn}" -ne 0 ] &&
        { _err "${ERR}Missing commands: ${warn[*]}.";
          return 1; }

    _msg "${PAS}verification of required commands completed"

    gpg --list-keys ${OPENPGP_SIGNING_KEY_ID} >/dev/null 2>&1 || (
        _err "${ERR}Missing OpenPGP public key.  Fetch it with this command:"
        echo "  gpg --keyserver pgp.mit.edu --recv-keys ${OPENPGP_SIGNING_KEY_ID}"
        exit 1
    )
}

chk_term()
{ # Check for ANSI terminal for color printing.
    local ansi_term

    if [ -t 2 ]; then
        if [ "${TERM+set}" = 'set' ]; then
            case "$TERM" in
                xterm*|rxvt*|urxvt*|linux*|vt*|eterm*|screen*)
                    ansi_term=true
                    ;;
                *)
                    ansi_term=false
                    ERR="[ FAIL ] "
                    PAS="[ PASS ] "
                    ;;
            esac
        fi
    fi
}

chk_init_sys()
{ # Return init system type name.
    if [[ $(/sbin/init --version 2>/dev/null) =~ upstart ]]; then
        _msg "${INF}init system is: upstart"
        INIT_SYS="upstart"
        return 0
    elif [[ $(systemctl) =~ -\.mount ]]; then
        _msg "${INF}init system is: systemd"
        INIT_SYS="systemd"
        return 0
    elif [[ -f /etc/init.d/cron && ! -h /etc/init.d/cron ]]; then
        _msg "${INF}init system is: sysv-init"
        INIT_SYS="sysv-init"
        return 0
    else
        INIT_SYS="NA"
        _err "${ERR}Init system could not be detected."
    fi
}

chk_sys_arch()
{ # Check for operating system and architecture type.
    local os
    local arch

    os="$(uname -s)"
    arch="$(uname -m)"

    case "$arch" in
        i386 | i486 | i686 | i786 | x86)
            local arch=i686
            ;;
        x86_64 | x86-64 | x64 | amd64)
            local arch=x86_64
            ;;
        aarch64)
            local arch=aarch64
            ;;
	armv7l)
	    local arch=armhf
	    ;;
        *)
            _err "${ERR}Unsupported CPU type: ${arch}"
            exit 1
    esac

    case "$os" in
        Linux | linux)
            local os=linux
            ;;
        *)
            _err "${ERR}Your operation system (${os}) is not supported."
            exit 1
    esac

    ARCH_OS="${arch}-${os}"
}

# ------------------------------------------------------------------------------
#+MAIN

guix_get_bin_list()
{ # Scan GNU archive and save list of binaries
    local gnu_url="$1"
    local -a bin_ver_ls
    local latest_ver
    local default_ver

    _debug "--- [ $FUNCNAME ] ---"

    # Filter only version and architecture
    bin_ver_ls=("$(wget -qO- "$gnu_url" \
        | sed -n -e 's/.*guix-binary-\([0-9.]*\)\..*.tar.xz.*/\1/p' \
        | sort -Vu)")

    latest_ver="$(echo "$bin_ver_ls" \
                       | grep -oP "([0-9]{1,2}\.){2}[0-9]{1,2}" \
                       | tail -n1)"

    default_ver="guix-binary-${latest_ver}.${ARCH_OS}"

    if [[ "${#bin_ver_ls}" -ne "0" ]]; then
        _msg "${PAS}Release for your system: ${default_ver}"
    else
        _err "${ERR}Could not obtain list of Guix releases."
        exit 1
    fi

    # Use default to download according to the list and local ARCH_OS.
    BIN_VER="$default_ver"
}

guix_get_bin()
{ # Download and verify binary package.
    local url="$1"
    local bin_ver="$2"
    local dl_path="$3"

    _debug "--- [ $FUNCNAME ] ---"

    _msg "${INF}Downloading Guix release archive"

    wget --help | grep -q '\--show-progress' && \
        _PROGRESS_OPT="-q --show-progress" || _PROGRESS_OPT=""
    wget $_PROGRESS_OPT -P "$dl_path" "${url}/${bin_ver}.tar.xz" "${url}/${bin_ver}.tar.xz.sig"

    if [[ "$?" -eq 0 ]]; then
       _msg "${PAS}download completed."
    else
        _err "${ERR}could not download ${url}/${bin_ver}.tar.xz."
        exit 1
    fi

    pushd $dl_path >/dev/null
    gpg --verify "${bin_ver}.tar.xz.sig" >/dev/null 2>&1
    if [[ "$?" -eq 0 ]]; then
        _msg "${PAS}Signature is valid."
        popd >/dev/null
    else
        _err "${ERR}could not verify the signature."
        exit 1
    fi
}

sys_create_store()
{ # Unpack and install /gnu/store and /var/guix
    local pkg="$1"
    local tmp_path="$2"

    _debug "--- [ $FUNCNAME ] ---"

    cd "$tmp_path"
    tar --warning=no-timestamp \
        --extract \
        --file "$pkg" &&
    _msg "${PAS}unpacked archive"

    if [[ -e "/var/guix" || -e "/gnu" ]]; then
        _err "${ERR}A previous Guix installation was found.  Refusing to overwrite."
        exit 1
    else
        _msg "${INF}Installing /var/guix and /gnu..."
        mv "${tmp_path}/var/guix" /var/
        mv "${tmp_path}/gnu" /
    fi

    _msg "${INF}Linking the root user's profile"
    ln -sf /var/guix/profiles/per-user/root/guix-profile \
       "${ROOT_HOME}/.guix-profile"

    GUIX_PROFILE="${ROOT_HOME}/.guix-profile"
    source "${GUIX_PROFILE}/etc/profile"
    _msg "${PAS}activated root profile at /root/.guix-profile"
}

sys_create_build_user()
{ # Create the group and user accounts for build users.

    _debug "--- [ $FUNCNAME ] ---"

    if [ $(getent group guixbuild) ]; then
        _msg "${INF}group guixbuild exists"
    else
        groupadd --system guixbuild
        _msg "${PAS}group <guixbuild> created"
    fi

    for i in $(seq -w 1 10); do
        if id "guixbuilder${i}" &>/dev/null; then
            _msg "${INF}user is already in the system, reset"
            usermod -g guixbuild -G guixbuild           \
                    -d /var/empty -s "$(which nologin)" \
                    -c "Guix build user $i"             \
                    "guixbuilder${i}";
        else
            useradd -g guixbuild -G guixbuild           \
                    -d /var/empty -s "$(which nologin)" \
                    -c "Guix build user $i" --system    \
                    "guixbuilder${i}";
            _msg "${PAS}user added <guixbuilder${i}>"
        fi
    done
}

sys_enable_guix_daemon()
{ # Run the daemon, and set it to automatically start on boot.

    local info_path
    local local_bin
    local var_guix

    _debug "--- [ $FUNCNAME ] ---"

    info_path="/usr/local/share/info"
    local_bin="/usr/local/bin"
    var_guix="/var/guix/profiles/per-user/root/guix-profile"

    case "$INIT_SYS" in
        upstart)
            { initctl reload-configuration;
              cp "${ROOT_HOME}/.guix-profile/lib/upstart/system/guix-daemon.conf" \
                 /etc/init/ &&
                  start guix-daemon; } &&
                _msg "${PAS}enabled Guix daemon via upstart"
            ;;
        systemd)
            { cp "${ROOT_HOME}/.guix-profile/lib/systemd/system/guix-daemon.service" \
                 /etc/systemd/system/;
              chmod 664 /etc/systemd/system/guix-daemon.service;
              systemctl daemon-reload &&
                  systemctl start guix-daemon &&
                  systemctl enable guix-daemon; } &&
                _msg "${PAS}enabled Guix daemon via systemd"
            ;;
        NA|*)
            _msg "${ERR}unsupported init system; run the daemon manually:"
            echo "  ${ROOT_HOME}/.guix-profile/bin/guix-daemon --build-users-group=guixbuild"
            ;;
    esac

    _msg "${INF}making the guix command available to other users"

    [ -e "$local_bin" ] || mkdir -p "$local_bin"
    ln -sf "${var_guix}/bin/guix"  "$local_bin"

    [ -e "$info_path" ] || mkdir -p "$info_path"
    for i in ${var_guix}/share/info/*; do
        ln -sf "$i" "$info_path"
    done
}

sys_authorize_build_farms()
{ # authorize the public keys of the two build farms
    while true; do
        read -p "Permit downloading pre-built package binaries from the project's build farms? (yes/no) " yn
        case $yn in
            [Yy]*) guix archive --authorize < "${ROOT_HOME}/.guix-profile/share/guix/hydra.gnu.org.pub" &&
                         _msg "${PAS}Authorized public key for hydra.gnu.org";
                   guix archive --authorize < "${ROOT_HOME}/.guix-profile/share/guix/berlin.guixsd.org.pub" &&
                       _msg "${PAS}Authorized public key for berlin.guixsd.org";
                   break;;
            [Nn]*) _msg "${INF}Skipped authorizing build farm public keys"
                   break;;
            *) _msg "Please answer yes or no.";
        esac
    done
}

welcome()
{
    cat<<"EOF"
    ░░░                                     ░░░
    ░░▒▒░░░░░░░░░               ░░░░░░░░░▒▒░░
     ░░▒▒▒▒▒░░░░░░░           ░░░░░░░▒▒▒▒▒░
         ░▒▒▒░░▒▒▒▒▒         ░░░░░░░▒▒░
               ░▒▒▒▒░       ░░░░░░
                ▒▒▒▒▒      ░░░░░░
                 ▒▒▒▒▒     ░░░░░
                 ░▒▒▒▒▒   ░░░░░
                  ▒▒▒▒▒   ░░░░░
                   ▒▒▒▒▒ ░░░░░
                   ░▒▒▒▒▒░░░░░
                    ▒▒▒▒▒▒░░░
                     ▒▒▒▒▒▒░
     _____ _   _ _    _    _____       _
    / ____| \ | | |  | |  / ____|     (_)
   | |  __|  \| | |  | | | |  __ _   _ ___  __
   | | |_ | . ' | |  | | | | |_ | | | | \ \/ /
   | |__| | |\  | |__| | | |__| | |_| | |>  <
    \_____|_| \_|\____/   \_____|\__,_|_/_/\_\

This script installs GNU Guix on your system

https://www.gnu.org/software/guix/
EOF
    echo -n "Press return to continue..."
    read -r  ANSWER
}

main()
{
    local tmp_path
    welcome

    _msg "Starting installation ($(date))"

    chk_term
    chk_require "${REQUIRE[*]}"
    chk_init_sys
    chk_sys_arch

    _msg "${INF}system is ${ARCH_OS}"

    tmp_path="$(mktemp -t -d guix.XXX)"

    guix_get_bin_list "${GNU_URL}"
    guix_get_bin "${GNU_URL}" "${BIN_VER}" "$tmp_path"

    sys_create_store "${BIN_VER}.tar.xz" "${tmp_path}"
    sys_create_build_user
    sys_enable_guix_daemon
    sys_authorize_build_farms

    _msg "${INF}cleaning up ${tmp_path}"
    rm -r "${tmp_path}"

    _msg "${PAS}Guix has successfully been installed!"
    _msg "${INF}Run 'info guix' to read the manual."
 }

main "$@"


code:
# This is a "job" for the Upstart init system to launch 'guix-daemon'.
# Drop it in /etc/init to have 'guix-daemon' automatically started.

description "Publish the GNU Guix store"

start on runlevel [2345]

stop on runlevel [016]

task

exec @localstatedir@/guix/profiles/per-user/root/guix-profile/bin/guix publish --user=nobody --port=8181

license: mit


code:
# This is a "service unit file" for the systemd init system to launch
# 'guix publish'.  Drop it in /etc/systemd/system or similar to have
# 'guix publish' automatically started.

[Unit]
Description=Publish the GNU Guix store

[Service]
ExecStart=@localstatedir@/guix/profiles/per-user/root/guix-profile/bin/guix publish --user=nobody --port=8181
Environment=GUIX_LOCPATH=/root/.guix-profile/lib/locale
RemainAfterExit=yes
StandardOutput=syslog
StandardError=syslog

# See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>.
TasksMax=1024

[Install]
WantedBy=multi-user.target


code:
#!@EMACS@ --script
;;; indent-code.el --- Run Emacs to indent a package definition.

;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>

;; 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This scripts indents the given file or package definition in the specified
;; file using Emacs.

;;; Code:

;; Load Scheme indentation rules from ".dir-locals.el".
(with-temp-buffer
  (scheme-mode)
  (let ((default-directory (file-name-as-directory load-file-name))
        (enable-local-variables :all))
    (hack-dir-local-variables)
    (hack-local-variables-apply)))

;; Add indentation info for Scheme constructs that are not Guix-specific.
;; This is normally provided by Geiser but this file is for people who may not
;; be running Geiser, so we just copy it here (from 'geiser-syntax.el').
(defmacro guix-syntax--scheme-indent (&rest pairs)
  `(progn ,@(mapcar (lambda (p)
                      `(put ',(car p) 'scheme-indent-function ',(cadr p)))
                    pairs)))

(guix-syntax--scheme-indent
 (and-let* 1)
 (case-lambda 0)
 (catch defun)
 (class defun)
 (dynamic-wind 0)
 (guard 1)
 (let*-values 1)
 (let-values 1)
 (let/ec 1)
 (letrec* 1)
 (match 1)
 (match-lambda 0)
 (match-lambda* 0)
 (match-let scheme-let-indent)
 (match-let* 1)
 (match-letrec 1)
 (opt-lambda 1)
 (parameterize 1)
 (parameterize* 1)
 (receive 2)
 (require-extension 0)
 (syntax-case 2)
 (test-approximate 1)
 (test-assert 1)
 (test-eq 1)
 (test-equal 1)
 (test-eqv 1)
 (test-group-with-cleanup 1)
 (test-runner-on-bad-count! 1)
 (test-runner-on-bad-end-name! 1)
 (test-runner-on-final! 1)
 (test-runner-on-group-begin! 1)
 (test-runner-on-group-end! 1)
 (test-runner-on-test-begin! 1)
 (test-runner-on-test-end! 1)
 (test-with-runner 1)
 (unless 1)
 (when 1)
 (while 1)
 (with-exception-handler 1)
 (with-syntax 1))

(pcase command-line-args-left
  (`(,file-name ,package-name)
   ;; Indent the definition of PACKAGE-NAME in FILE-NAME.
   (find-file file-name)
   (goto-char (point-min))
   (if (re-search-forward (concat "^(define\\(-public\\) +"
                                  package-name)
                          nil t)
       (let ((indent-tabs-mode nil))
         (beginning-of-defun)
         (indent-sexp)
         (save-buffer)
         (message "Done!"))
     (error "Package '%s' not found in '%s'"
            package-name file-name)))
  (`(,file-name)
   ;; Indent all of FILE-NAME.
   (find-file file-name)
   (let ((indent-tabs-mode nil))
     (indent-region (point-min) (point-max))
     (save-buffer)
     (message "Done!")))
  (x
   (error "Usage: indent-code.el FILE [PACKAGE]")))

;;; indent-code.el ends here


code:
# -*- mode: snippet -*-
# name: guix-cvs-reference
# key: cvs-reference...
# --
(cvs-reference
  (root-directory "${1:root-directory}")
  (module "${2:module}")
  (revision "${3:revision}"))


code:
# -*- mode: snippet -*-
# name: guix-git-reference
# key: git-reference...
# --
(git-reference
  (url "$1")
  (commit ${2:commit}))


code:
# -*- mode: snippet -*-
# name: guix-hg-reference
# key: hg-reference...
# --
(hg-reference
  (url "$1")
  (changeset ${2:changeset}))


code:
# -*- mode: snippet -*-
# name: guix-origin
# key: origin...
# --
(origin
 (method ${1:$$(yas-choose-value "url-fetch"
                                 "url-fetch/tarbomb"
                                 "url-fetch/zipbomb"
                                 "cvs-fetch"
                                 "git-fetch"
                                 "hg-fetch"
                                 "svn-fetch")})
 (uri ${1:$(cond ((equal yas-text "git-fetch") "git-reference...")
                 ((equal yas-text "svn-fetch") "svn-reference...")
                 ((equal yas-text "hg-fetch")  "hg-reference...")
                 ((equal yas-text "cvs-fetch") "cvs-reference...")
                 (t "(string-append \\"https://\\" version \\".tar.gz\\")"))}$0)
 ${1:$(cond ((equal yas-text "git-fetch")
             "(file-name (git-file-name name version))")
            ((member yas-text '("svn-fetch" "hg-fetch" "cvs-fetch"))
             "(file-name (string-append name \\"-\\" version \\"-checkout\\"))")
            (t ""))}
 (sha256
  (base32
    "$2")))

path: etc/snippets/scheme-mode/guix-origin


code:
# -*- mode: snippet -*-
# name: guix-package
# key: package...
# --
(define-public $1
  (package
    (name "$1")
    (version "$2")
    (source origin...$0)
    (build-system ${3:$$(yas-choose-value "android-ndk-build-system"
                                          "ant-build-system"
                                          "asdf-build-system"
                                          "cargo-build-system"
                                          "cmake-build-system"
                                          "dub-build-system"
                                          "emacs-build-system"
                                          "font-build-system"
                                          "glib-or-gtk-build-system"
                                          "gnu-build-system"
                                          "go-build-system"
                                          "haskell-build-system"
                                          "meson-build-system"
                                          "minify-build-system"
                                          "ocaml-build-system"
                                          "perl-build-system"
                                          "python-build-system"
                                          "r-build-system"
                                          "ruby-build-system"
                                          "scons-build-system"
                                          "texlive-build-system"
                                          "trivial-build-system"
                                          "waf-build-system")})
    (home-page "$4")
    (synopsis "$5")
    (description "$6")
    (license $7)))

path: etc/snippets/scheme-mode/guix-package


code:
# -*- mode: snippet -*-
# name: guix-svn-reference
# key: svn-reference...
# --
(svn-reference
  (url "$1")
  (revision ${2:svn-revision}))


code:
# -*- mode: snippet -*-
# name: guix-commit-message-add-package
# key: add
# condition: git-commit-mode
# --
gnu: Add $1.

* `(car (magit-staged-files))` ($1): New variable.


code:
# -*- mode: snippet -*-
# name: guix-commit-message-update-package
# key: update
# condition: git-commit-mode
# --
gnu: $1: Update to $2.

* `(car (magit-staged-files))` ($1): Update to $2.$0
`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")`


code:
# -*- mode: snippet -*-
# name: guix-commit-message-use-https-home-page
# key: https
# condition: git-commit-mode
# --
gnu: $1: Use HTTPS home page URI.

* `(car (magit-staged-files))` ($1)[home-page]: Use HTTPS URI.
`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")`


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Joshua S. Grant <jgrant@parenthetical.io>
;;; 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)
  #:use-module (guix i18n)
  #:use-module (guix utils)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (gnu services)
  #:export (use-package-modules
            use-service-modules
            use-system-modules))

;;; Commentary:
;;;
;;; This composite module re-exports core parts the (gnu …) public modules.
;;;
;;; Code:

(eval-when (eval load compile)
  (begin
    (define %public-modules
      '((gnu system)
        (gnu system mapped-devices)
        (gnu system file-systems)
        (gnu bootloader)
        (gnu bootloader grub)
        (gnu system pam)
        (gnu system shadow)                       ; 'user-account'
        (gnu system linux-initrd)
        (gnu system nss)
        (gnu services)
        (gnu services base)
        (gnu packages)
        (gnu packages base)
        (guix gexp)))                             ; so gexps can be used

    (for-each (let ((i (module-public-interface (current-module))))
                (lambda (m)
                  (module-use! i (resolve-interface m))))
              %public-modules)))

(define (%try-use-modules modules location make-hint)
  "Attempt to load all of MODULES.  Report errors as coming from LOCATION, a
<location> record, and use MAKE-HINT to produce a fix hint."
  (define (location->string loc)
    (match loc
      (#f "")
      (($ <location> file line column)
       (format #f "~a:~a:~a: " file line column))))

  (for-each (lambda (module)
              (catch 'misc-error
                (lambda ()
                  (process-use-modules `((,module))))
                (lambda _
                  (raise
                   (apply
                    make-compound-condition
                    (condition
                     (&message
                      (message (format #f (G_ "module ~a not found")
                                       module))))
                    (condition
                     (&error-location (location location)))
                    (or (and=> (make-hint module) list)
                        '()))))))
            modules))

(define (package-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       (symbol->string last))))

  (match (find-packages-by-name last-name)
    (()
     (condition
      (&fix-hint
       (hint (G_ "\
You may use @command{guix package --show=foo | grep location} to search
for the location of package @code{foo}.
If you get the line @code{location: gnu/packages/bar.scm:174:2},
add @code{bar} to the @code{use-package-modules} form.")))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-package-modules ~a)}.")
                     (basename (location-file (package-location package))
                               ".scm"))))))))

(define (service-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       last)))

  (match (lookup-service-types last-name)
    (()
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
You may use @command{guix system search ~a} to search for a service
matching @code{~a}.
If you get the line @code{location: gnu/services/foo.scm:188:2},
add @code{foo} to the @code{use-service-modules} form.")
                     last-name last-name)))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-service-modules ~a)}.")
                     (basename (location-file (service-type-location package))
                               ".scm"))))))))

(define-syntax-rule (try-use-modules hint modules ...)
  (eval-when (expand load eval)
    (%try-use-modules '(modules ...)
                      (source-properties->location
                       (current-source-location))
                      hint)))

(define-syntax-rule (use-package-modules module ...)
  (try-use-modules package-module-hint
                   (gnu packages module) ...))

(define-syntax-rule (use-service-modules module ...)
  (try-use-modules service-module-hint
                   (gnu services module) ...))

(define-syntax-rule (use-system-modules module ...)
  (try-use-modules (const #f)                     ;no hint
                   (gnu system module) ...))

;;; gnu.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;;
;;; 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 artwork)
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:export (%artwork-repository))

;;; Commentary:
;;;
;;; Common place for the definition of the Guix artwork repository.
;;;
;;; Code:

(define %artwork-repository
  (let ((commit "6998d30425289b087c64f63e7415df2241e591db"))
    (origin
      (method git-fetch)
      (uri (git-reference
             (url "git://git.savannah.gnu.org/guix/guix-artwork.git")
             (commit commit)))
      (file-name (string-append "guix-artwork-" (string-take commit 7)
                                "-checkout"))
      (sha256
       (base32
        "0k7j3pj9s3zqiqmfkapypssvzx3f12yr0cc2rbzxqfii0b4clp1j")))))

;;; artwork.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;;
;;; 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 bootloader)
  #:use-module (guix discovery)
  #:use-module (guix records)
  #:use-module (guix ui)
  #:use-module (srfi srfi-1)
  #:export (menu-entry
            menu-entry?
            menu-entry-label
            menu-entry-device
            menu-entry-linux
            menu-entry-linux-arguments
            menu-entry-initrd
            menu-entry-device-mount-point

            bootloader
            bootloader?
            bootloader-name
            bootloader-package
            bootloader-installer
            bootloader-configuration-file
            bootloader-configuration-file-generator

            bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-target
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-theme
            bootloader-configuration-terminal-outputs
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
            bootloader-configuration-additional-configuration

            %bootloaders
            lookup-bootloader-by-name))

;;;
;;; Menu-entry record.
;;;

(define-record-type* <menu-entry>
  menu-entry make-menu-entry
  menu-entry?
  (label           menu-entry-label)
  (device          menu-entry-device       ; file system uuid, label, or #f
                   (default #f))
  (device-mount-point menu-entry-device-mount-point
                   (default #f))
  (linux           menu-entry-linux)
  (linux-arguments menu-entry-linux-arguments
                   (default '()))          ; list of string-valued gexps
  (initrd          menu-entry-initrd))     ; file name of the initrd as a gexp

;;;
;;; Bootloader record.
;;;

;; The <bootloader> record contains fields expressing how the bootloader
;; should be installed. Every bootloader in gnu/bootloader/ directory
;; has to be described by this record.

(define-record-type* <bootloader>
  bootloader make-bootloader
  bootloader?
  (name                            bootloader-name)
  (package                         bootloader-package)
  (installer                       bootloader-installer)
  (configuration-file              bootloader-configuration-file)
  (configuration-file-generator    bootloader-configuration-file-generator))

;;;
;;; Bootloader configuration record.
;;;

;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader                      bootloader-configuration-bootloader)    ; <bootloader>
  (device                          bootloader-configuration-device         ; string
                                   (default #f))
  (target                          %bootloader-configuration-target         ; 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        ; seconds as integer
                                   (default 5))
  (theme                           bootloader-configuration-theme          ; bootloader-specific theme
                                   (default #f))
  (terminal-outputs                bootloader-configuration-terminal-outputs ; list of symbols
                                   (default '(gfxterm)))
  (terminal-inputs                 bootloader-configuration-terminal-inputs  ; list of symbols
                                   (default '()))
  (serial-unit                     bootloader-configuration-serial-unit      ; integer | #f
                                   (default #f))
  (serial-speed                    bootloader-configuration-serial-speed     ; integer | #f
                                   (default #f))
  (additional-configuration        bootloader-configuration-additional-configuration ; record
                                   (default #f)))

(define (bootloader-configuration-target config)
  (or (%bootloader-configuration-target config)
      (let ((device (bootloader-configuration-device config)))
        (when device
          (warning
           (G_ "The 'device' field of bootloader configurations is deprecated.~%"))
          (warning (G_ "Use 'target' instead.~%")))
        device)))

;;;
;;; Bootloaders.
;;;

(define (bootloader-modules)
  "Return the list of bootloader modules."
  (all-modules (map (lambda (entry)
                      `(,entry . "gnu/bootloader"))
                    %load-path)
               #:warn warn-about-load-error))

(define %bootloaders
  ;; The list of publically-known bootloaders.
  (delay (fold-module-public-variables (lambda (obj result)
                                         (if (bootloader? obj)
                                             (cons obj result)
                                             result))
                                       '()
                                       (bootloader-modules))))

(define (lookup-bootloader-by-name name)
  "Return the bootloader called NAME."
  (or (find (lambda (bootloader)
              (eq? name (bootloader-name bootloader)))
            (force %bootloaders))
      (leave (G_ "~a: no such bootloader~%") name)))


code:
;;; 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 bootloader extlinux)
  #:use-module (gnu bootloader)
  #:use-module (gnu system)
  #:use-module (gnu build bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:export (extlinux-bootloader
            extlinux-bootloader-gpt))

(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 (menu-entry->gexp entry)
    (let ((label (menu-entry-label entry))
          (kernel (menu-entry-linux entry))
          (kernel-arguments (menu-entry-linux-arguments entry))
          (initrd (menu-entry-initrd entry)))
      #~(format port "LABEL ~a
  MENU LABEL ~a
  KERNEL ~a
  FDTDIR ~a/lib/dtbs
  INITRD ~a
  APPEND ~a
~%"
                #$label #$label
                #$kernel (dirname #$kernel) #$initrd
                (string-join (list #$@kernel-arguments)))))

  (define builder
    #~(call-with-output-file #$output
        (lambda (port)
          (let ((timeout #$(bootloader-configuration-timeout config)))
            (format port "# This file was generated from your GuixSD configuration.  Any changes
# will be lost upon reconfiguration.
UI menu.c32
MENU TITLE GuixSD Boot Options
PROMPT ~a
TIMEOUT ~a~%"
                    (if (> timeout 0) 1 0)
                    ;; timeout is expressed in 1/10s of seconds.
                    (* 10 timeout))
            #$@(map menu-entry->gexp all-entries)

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

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

;;;
;;; Install procedures.
;;;

(define (install-extlinux mbr)
  #~(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")))
        (for-each (lambda (file)
                    (install-file file install-dir))
                  (find-files syslinux-dir "\\.c32$"))
        (unless
            (and (zero? (system* extlinux "--install" install-dir))
                 (write-file-on-device
                  (string-append syslinux-dir "/" #$mbr) 440 device 0))
          (error "failed to install SYSLINUX")))))

(define install-extlinux-mbr
  (install-extlinux "mbr.bin"))

(define install-extlinux-gpt
  (install-extlinux "gptmbr.bin"))

;;;
;;; Bootloader definitions.
;;;

(define extlinux-bootloader
  (bootloader
   (name 'extlinux)
   (package syslinux)
   (installer install-extlinux-mbr)
   (configuration-file "/boot/extlinux/extlinux.conf")
   (configuration-file-generator extlinux-configuration-file)))

(define extlinux-bootloader-gpt
  (bootloader
   (inherit extlinux-bootloader)
   (installer install-extlinux-gpt)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; 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 bootloader grub)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix records)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix download)
  #:use-module (gnu artwork)
  #:use-module (gnu system)
  #:use-module (gnu bootloader)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:autoload   (gnu packages bootloaders) (grub)
  #:autoload   (gnu packages compression) (gzip)
  #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
  #:autoload   (gnu packages guile) (guile-2.2)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (rnrs bytevectors)
  #:export (grub-image
            grub-image?
            grub-image-aspect-ratio
            grub-image-file

            grub-theme
            grub-theme?
            grub-theme-images
            grub-theme-color-normal
            grub-theme-color-highlight

            %background-image
            %default-theme

            grub-bootloader
            grub-efi-bootloader
            grub-mkrescue-bootloader

            grub-configuration))

;;; Commentary:
;;;
;;; Configuration of GNU GRUB.
;;;
;;; Code:

(define (strip-mount-point mount-point file)
  "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
denoting a file name."
  (match mount-point
    ((? string? mount-point)
     (if (string=? mount-point "/")
         file
         #~(let ((file #$file))
             (if (string-prefix? #$mount-point file)
                 (substring #$file #$(string-length mount-point))
                 file))))
    (#f file)))

(define-record-type* <grub-image>
  grub-image make-grub-image
  grub-image?
  (aspect-ratio    grub-image-aspect-ratio        ;rational number
                   (default 4/3))
  (file            grub-image-file))              ;file-valued gexp (SVG)

(define-record-type* <grub-theme>
  grub-theme make-grub-theme
  grub-theme?
  (images          grub-theme-images
                   (default '()))                 ;list of <grub-image>
  (color-normal    grub-theme-color-normal
                   (default '((fg . cyan) (bg . blue))))
  (color-highlight grub-theme-color-highlight
                   (default '((fg . white) (bg . blue)))))

(define %background-image
  (grub-image
   (aspect-ratio 4/3)
   (file (file-append %artwork-repository
                      "/grub/GuixSD-fully-black-4-3.svg"))))

(define %default-theme
  ;; Default theme contributed by Felipe López.
  (grub-theme
   (images (list %background-image))
   (color-highlight '((fg . yellow) (bg . black)))
   (color-normal    '((fg . light-gray) (bg . black))))) ;XXX: #x303030

;;;
;;; Background image & themes.
;;;

(define (bootloader-theme config)
  "Return user defined theme in CONFIG if defined or %default-theme
otherwise."
  (or (bootloader-configuration-theme config) %default-theme))

(define* (svg->png svg #:key width height)
  "Build a PNG of HEIGHT x WIDTH from SVG."
  (gexp->derivation "grub-image.png"
                    (with-imported-modules '((gnu build svg))
                      (with-extensions (list guile-rsvg guile-cairo)
                        #~(begin
                            (use-modules (gnu build svg))
                            (svg->png #+svg #$output
                                      #:width #$width
                                      #:height #$height))))))

(define* (grub-background-image config #:key (width 1024) (height 768))
  "Return the GRUB background image defined in CONFIG with a ratio of
WIDTH/HEIGHT, or #f if none was found."
  (let* ((ratio (/ width height))
         (image (find (lambda (image)
                        (= (grub-image-aspect-ratio image) ratio))
                      (grub-theme-images
                       (bootloader-theme config)))))
    (if image
        (svg->png (grub-image-file image)
                  #:width width #:height height)
        (with-monad %store-monad
          (return #f)))))

(define* (eye-candy config store-device store-mount-point
                    #:key system port)
  "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
'grub.cfg' part concerned with graphics mode, background images, colors, and
all that.  STORE-DEVICE designates the device holding the store, and
STORE-MOUNT-POINT is its mount point; these are used to determine where the
background image and fonts must be searched for.  SYSTEM must be the target
system string---e.g., \"x86_64-linux\"."
  (define setup-gfxterm-body
    ;; Intel and EFI systems need to be switched into graphics mode, whereas
    ;; most other modern architectures have no other mode and therefore don't
    ;; need to be switched.
    (if (string-match "^(x86_64|i[3-6]86)-" system)
        "
  # Leave 'gfxmode' to 'auto'.
  insmod video_bochs
  insmod video_cirrus
  insmod gfxterm

  if [ \"${grub_platform}\" == efi ]; then
    # This is for (U)EFI systems (these modules are unavailable in the
    # non-EFI GRUB.)  If we don't load them, GRUB boots in \"blind mode\",
    # which isn't convenient.
    insmod efi_gop
    insmod efi_uga
  else
    # These are specific to non-EFI Intel machines.
    insmod vbe
    insmod vga
  fi
"
        ""))

  (define (setup-gfxterm config font-file)
    (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
        #~(format #f "if loadfont ~a; then
  setup_gfxterm
fi~%" #$font-file)
        ""))

  (define (theme-colors type)
    (let* ((theme  (bootloader-theme config))
           (colors (type theme)))
      (string-append (symbol->string (assoc-ref colors 'fg)) "/"
                     (symbol->string (assoc-ref colors 'bg)))))

  (define font-file
    (strip-mount-point store-mount-point
                       (file-append grub "/share/grub/unicode.pf2")))

  (mlet* %store-monad ((image (grub-background-image config)))
    (return (and image
                 #~(format #$port "
function setup_gfxterm {~a}

# Set 'root' to the partition that contains /gnu/store.
~a

~a
~a

insmod png
if background_image ~a; then
  set color_normal=~a
  set color_highlight=~a
else
  set menu_color_normal=cyan/blue
  set menu_color_highlight=white/blue
fi~%"
                           #$setup-gfxterm-body
                           #$(grub-root-search store-device font-file)
                           #$(setup-gfxterm config font-file)
                           #$(grub-setup-io config)

                           #$(strip-mount-point store-mount-point image)
                           #$(theme-colors grub-theme-color-normal)
                           #$(theme-colors grub-theme-color-highlight))))))

;;;
;;; Configuration file.
;;;

(define (grub-setup-io config)
  "Return GRUB commands to configure the input / output interfaces.  The result
is a string that can be inserted in grub.cfg."
  (let* ((symbols->string (lambda (list)
                           (string-join (map symbol->string list) " ")))
         (outputs (bootloader-configuration-terminal-outputs config))
         (inputs (bootloader-configuration-terminal-inputs config))
         (unit (bootloader-configuration-serial-unit config))
         (speed (bootloader-configuration-serial-speed config))

         ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
         ;; as documented in GRUB manual section "Simple Configuration
         ;; Handling".
         (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3
                          gfxterm vga_text mda_text morse spkmodem))
         (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3
                         at_keyboard usb_keyboard))

         (io (string-append
               "terminal_output "
               (symbols->string
                 (map
                   (lambda (output)
                     (if (memq output valid-outputs) output #f)) outputs)) "\n"
               (if (null? inputs)
                 ""
                 (string-append
                   "terminal_input "
                   (symbols->string
                     (map
                       (lambda (input)
                         (if (memq input valid-inputs) input #f)) inputs)) "\n"))
               ;; UNIT and SPEED are arguments to the same GRUB command
               ;; ("serial"), so we process them together.
               (if (or unit speed)
                 (string-append
                   "serial"
                   (if unit
                     ;; COM ports 1 through 4
                     (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
                       (string-append " --unit=" (number->string unit))
                       #f)
                     "")
                   (if speed
                     (if (exact-integer? speed)
                       (string-append " --speed=" (number->string speed))
                       #f)
                     ""))
                 ""))))
    (format #f "~a" io)))

(define (grub-root-search device file)
  "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
a gexp.  The result is a gexp that can be inserted in the grub.cfg-generation
code."
  ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
  ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
  ;; custom menu entries.  In the latter case, don't emit a 'search' command.
  (if (and (string? file) (not (string-prefix? "/" file)))
      ""
      (match device
        ;; Preferably refer to DEVICE by its UUID or label.  This is more
        ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
        ((? uuid? uuid)
         (format #f "search --fs-uuid --set ~a"
                 (uuid->string device)))
        ((? file-system-label? label)
         (format #f "search --label --set ~a"
                 (file-system-label->string label)))
        ((or #f (? string?))
         #~(format #f "search --file --set ~a" #$file)))))

(define* (grub-configuration-file config entries
                                  #:key
                                  (system (%current-system))
                                  (old-entries '()))
  "Return the GRUB configuration file corresponding to CONFIG, a
<bootloader-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 (menu-entry->gexp entry)
    (let ((device (menu-entry-device entry))
          (device-mount-point (menu-entry-device-mount-point entry))
          (label (menu-entry-label entry))
          (kernel (menu-entry-linux entry))
          (arguments (menu-entry-linux-arguments entry))
          (initrd (menu-entry-initrd entry)))
      ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
      ;; Use the right file names for KERNEL and INITRD in case
      ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
      ;; separate partition.
      (let ((kernel  (strip-mount-point device-mount-point kernel))
            (initrd  (strip-mount-point device-mount-point initrd)))
        #~(format port "menuentry ~s {
  ~a
  linux ~a ~a
  initrd ~a
}~%"
                  #$label
                  #$(grub-root-search device kernel)
                  #$kernel (string-join (list #$@arguments))
                  #$initrd))))
  (mlet %store-monad ((sugar (eye-candy config
                                        (menu-entry-device
                                         (first all-entries))
                                        (menu-entry-device-mount-point
                                         (first all-entries))
                                        #:system system
                                        #:port #~port)))
    (define builder
      #~(call-with-output-file #$output
          (lambda (port)
            (format port
                    "# This file was generated from your GuixSD configuration.  Any changes
# will be lost upon reconfiguration.
")
            #$sugar
            (format port "
set default=~a
set timeout=~a~%"
                    #$(bootloader-configuration-default-entry config)
                    #$(bootloader-configuration-timeout config))
            #$@(map menu-entry->gexp all-entries)

            #$@(if (pair? old-entries)
                   #~((format port "
submenu \"GNU system, old configurations...\" {~%")
                      #$@(map menu-entry->gexp old-entries)
                      (format port "}~%"))
                   #~()))))

    (gexp->derivation "grub.cfg" builder)))

;;;
;;; Install procedures.
;;;

(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" "--target=i386-pc"
                                "--boot-directory" install-dir
                                device))
          (error "failed to install GRUB (BIOS)")))))

(define install-grub-efi
  #~(lambda (bootloader efi-dir mount-point)
      ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
      ;; system whose root is mounted at MOUNT-POINT.
      (let ((grub-install (string-append bootloader "/sbin/grub-install"))
            (install-dir (string-append mount-point "/boot"))
            ;; When installing GuixSD, it's common to mount EFI-DIR below
            ;; MOUNT-POINT rather than /boot/efi on the live image.
            (target-esp (if (file-exists? (string-append mount-point efi-dir))
                            (string-append mount-point efi-dir)
                            efi-dir)))
        ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
        ;; root partition.
        (setenv "GRUB_ENABLE_CRYPTODISK" "y")
        (unless (zero? (system* grub-install "--boot-directory" install-dir
                                "--bootloader-id=GuixSD"
                                "--efi-directory" target-esp))
          (error "failed to install GRUB (EFI)")))))

;;;
;;; Bootloader definitions.
;;;

(define grub-bootloader
  (bootloader
   (name 'grub)
   (package grub)
   (installer install-grub)
   (configuration-file "/boot/grub/grub.cfg")
   (configuration-file-generator grub-configuration-file)))

(define* grub-efi-bootloader
  (bootloader
   (inherit grub-bootloader)
   (installer install-grub-efi)
   (name 'grub-efi)
   (package grub-efi)))

(define* grub-mkrescue-bootloader
  (bootloader
   (inherit grub-efi-bootloader)
   (package grub-hybrid)))

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

(define-syntax grub-configuration
  (syntax-rules (grub)
                ((_ (grub package) fields ...)
                 (if (eq? package grub)
                     (bootloader-configuration
                      (bootloader grub-bootloader)
                      fields ...)
                   (bootloader-configuration
                    (bootloader grub-efi-bootloader)
                    fields ...)))
                ((_ fields ...)
                 (bootloader-configuration
                  (bootloader grub-bootloader)
                  fields ...))))

;;; grub.scm ends here


code:
;;; 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 bootloader u-boot)
  #:use-module (gnu bootloader extlinux)
  #:use-module (gnu bootloader)
  #:use-module (gnu system)
  #:use-module (gnu build bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:export (u-boot-bootloader
            u-boot-a20-olinuxino-lime-bootloader
            u-boot-a20-olinuxino-lime2-bootloader
            u-boot-a20-olinuxino-micro-bootloader
            u-boot-bananapi-m2-ultra-bootloader
            u-boot-beaglebone-black-bootloader
            u-boot-mx6cuboxi-bootloader
            u-boot-nintendo-nes-classic-edition-bootloader
            u-boot-novena-bootloader
            u-boot-pine64-plus-bootloader
            u-boot-puma-rk3399-bootloader
            u-boot-wandboard-bootloader))

(define install-u-boot
  #~(lambda (bootloader device mount-point)
      (if bootloader
        (error "Failed to install U-Boot"))))

(define install-beaglebone-black-u-boot
  ;; http://wiki.beyondlogic.org/index.php?title=BeagleBoneBlack_Upgrading_uBoot
  ;; This first stage bootloader called MLO (U-Boot SPL) is expected at
  ;; 0x20000 by BBB ROM code. The second stage bootloader will be loaded by
  ;; the MLO and is expected at 0x60000.  Write both first stage ("MLO") and
  ;; second stage ("u-boot.img") images, read in BOOTLOADER directory, to the
  ;; specified DEVICE.
  #~(lambda (bootloader device mount-point)
      (let ((mlo (string-append bootloader "/libexec/MLO"))
            (u-boot (string-append bootloader "/libexec/u-boot.img")))
        (write-file-on-device mlo (* 256 512)
                              device (* 256 512))
        (write-file-on-device u-boot (* 1024 512)
                              device (* 768 512)))))

(define install-allwinner-u-boot
  #~(lambda (bootloader device mount-point)
      (let ((u-boot (string-append bootloader
                                   "/libexec/u-boot-sunxi-with-spl.bin")))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              device (* 8 1024)))))

(define install-allwinner64-u-boot
  #~(lambda (bootloader device mount-point)
      (let ((spl (string-append bootloader "/libexec/spl/sunxi-spl.bin"))
            (u-boot (string-append bootloader "/libexec/u-boot.itb")))
        (write-file-on-device spl (stat:size (stat spl))
                              device (* 8 1024))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              device (* 40 1024)))))

(define install-imx-u-boot
  #~(lambda (bootloader device mount-point)
      (let ((spl (string-append bootloader "/libexec/SPL"))
            (u-boot (string-append bootloader "/libexec/u-boot.img")))
        (write-file-on-device spl (stat:size (stat spl))
                              device (* 1 1024))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              device (* 69 1024)))))

(define install-puma-rk3399-u-boot
  #~(lambda (bootloader device mount-point)
      (let ((spl (string-append bootloader "/libexec/u-boot-spl.rksd"))
            (u-boot (string-append bootloader "/libexec/u-boot.itb")))
        (write-file-on-device spl (stat:size (stat spl))
                              device (* 64 512))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              device (* 512 512)))))

;;;
;;; Bootloader definitions.
;;;

(define u-boot-bootloader
  (bootloader
   (inherit extlinux-bootloader)
   (name 'u-boot)
   (package #f)
   (installer install-u-boot)))

(define u-boot-beaglebone-black-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-beagle-bone-black)
   (installer install-beaglebone-black-u-boot)))

(define u-boot-allwinner-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (installer install-allwinner-u-boot)))

(define u-boot-allwinner64-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (installer install-allwinner64-u-boot)))

(define u-boot-imx-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (installer install-imx-u-boot)))

(define u-boot-nintendo-nes-classic-edition-bootloader
  (bootloader
    (inherit u-boot-allwinner-bootloader)
    (package u-boot-nintendo-nes-classic-edition)))

(define u-boot-a20-olinuxino-lime-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-a20-olinuxino-lime)))

(define u-boot-a20-olinuxino-lime2-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-a20-olinuxino-lime2)))

(define u-boot-a20-olinuxino-micro-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-a20-olinuxino-micro)))

(define u-boot-bananapi-m2-ultra-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-bananapi-m2-ultra)))

(define u-boot-mx6cuboxi-bootloader
  (bootloader
   (inherit u-boot-imx-bootloader)
   (package u-boot-mx6cuboxi)))

(define u-boot-wandboard-bootloader
  (bootloader
   (inherit u-boot-imx-bootloader)
   (package u-boot-wandboard)))

(define u-boot-novena-bootloader
  (bootloader
   (inherit u-boot-imx-bootloader)
   (package u-boot-novena)))

(define u-boot-pine64-plus-bootloader
  (bootloader
   (inherit u-boot-allwinner64-bootloader)
   (package u-boot-pine64-plus)))

(define u-boot-puma-rk3399-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-puma-rk3399)
   (installer install-puma-rk3399-u-boot)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; 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 build activation)
  #:use-module (gnu build linux-boot)
  #:use-module (guix build utils)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (activate-users+groups
            activate-user-home
            activate-etc
            activate-setuid-programs
            activate-special-files
            activate-modprobe
            activate-firmware
            activate-ptrace-attach
            activate-current-system))

;;; Commentary:
;;;
;;; This module provides "activation" helpers.  Activation is the process that
;;; consists in setting up system-wide files and directories so that an
;;; 'operating-system' configuration becomes active.
;;;
;;; Code:

(define (enumerate thunk)
  "Return the list of values returned by THUNK until it returned #f."
  (let loop ((entry  (thunk))
             (result '()))
    (if (not entry)
        (reverse result)
        (loop (thunk) (cons entry result)))))

(define (current-users)
  "Return the passwd entries for all the currently defined user accounts."
  (setpw)
  (enumerate getpwent))

(define (current-groups)
  "Return the group entries for all the currently defined user groups."
  (setgr)
  (enumerate getgrent))

(define* (add-group name #:key gid password system?
                    (log-port (current-error-port)))
  "Add NAME as a user group, with the given numeric GID if specified."
  ;; Use 'groupadd' from the Shadow package.
  (format log-port "adding group '~a'...~%" name)
  (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
                ,@(if password `("-p" ,password) '())
                ,@(if system? `("--system") '())
                ,name)))
    (zero? (apply system* "groupadd" args))))

(define %skeleton-directory
  ;; Directory containing skeleton files for new accounts.
  ;; Note: keep the trailing '/' so that 'scandir' enters it.
  "/etc/skel/")

(define (dot-or-dot-dot? file)
  (member file '("." "..")))

(define* (copy-account-skeletons home
                                 #:key
                                 (directory %skeleton-directory)
                                 uid gid)
  "Copy the account skeletons from DIRECTORY to HOME.  When UID is an integer,
make it the owner of all the files created; likewise for GID."
  (define (set-owner file)
    (when (or uid gid)
      (chown file (or uid -1) (or gid -1))))

  (let ((files (scandir directory (negate dot-or-dot-dot?)
                        string<?)))
    (mkdir-p home)
    (set-owner home)
    (for-each (lambda (file)
                (let ((target (string-append home "/" file)))
                  (copy-recursively (string-append directory "/" file)
                                    target
                                    #:log (%make-void-port "w"))
                  (for-each set-owner
                            (find-files target (const #t)
                                        #:directories? #t))
                  (make-file-writable target)))
              files)))

(define* (make-skeletons-writable home
                                  #:optional (directory %skeleton-directory))
  "Make sure that the files that have been copied from DIRECTORY to HOME are
owner-writable in HOME."
  (let ((files (scandir directory (negate dot-or-dot-dot?)
                        string<?)))
    (for-each (lambda (file)
                (let ((target (string-append home "/" file)))
                  (when (file-exists? target)
                    (make-file-writable target))))
              files)))

(define* (add-user name group
                   #:key uid comment home create-home?
                   shell password system?
                   (supplementary-groups '())
                   (log-port (current-error-port)))
  "Create an account for user NAME part of GROUP, with the specified
properties.  Return #t on success."
  (format log-port "adding user '~a'...~%" name)

  (if (and uid (zero? uid))

      ;; 'useradd' fails with "Cannot determine your user name" if the root
      ;; account doesn't exist.  Thus, for bootstrapping purposes, create that
      ;; one manually.
      (let ((home (or home "/root")))
        (call-with-output-file "/etc/shadow"
          (cut format <> "~a::::::::~%" name))
        (call-with-output-file "/etc/passwd"
          (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
               name "0" "0" comment home shell))
        (chmod "/etc/shadow" #o600)
        (copy-account-skeletons home)
        (chmod home #o700)
        #t)

      ;; Use 'useradd' from the Shadow package.
      (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
                    "-g" ,(if (number? group) (number->string group) group)
                    ,@(if (pair? supplementary-groups)
                          `("-G" ,(string-join supplementary-groups ","))
                          '())
                    ,@(if comment `("-c" ,comment) '())
                    ,@(if (and home create-home?)
                          (if (file-exists? home)
                              `("-d" ,home)     ; avoid warning from 'useradd'
                              `("-d" ,home "--create-home"))
                          '())
                    ,@(if shell `("-s" ,shell) '())
                    ,@(if password `("-p" ,password) '())
                    ,@(if system? '("--system") '())
                    ,name)))
        (and (zero? (apply system* "useradd" args))
             (begin
               ;; Since /etc/skel is a link to a directory in the store where
               ;; all files have the writable bit cleared, and since 'useradd'
               ;; preserves permissions when it copies them, explicitly make
               ;; them writable.
               (make-skeletons-writable home)
               #t)))))

(define* (modify-user name group
                      #:key uid comment home create-home?
                      shell password system?
                      (supplementary-groups '())
                      (log-port (current-error-port)))
  "Modify user account NAME to have all the given settings."
  ;; Use 'usermod' from the Shadow package.
  (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
                "-g" ,(if (number? group) (number->string group) group)
                ,@(if (pair? supplementary-groups)
                      `("-G" ,(string-join supplementary-groups ","))
                      '())
                ,@(if comment `("-c" ,comment) '())
                ;; Don't use '--move-home'.
                ,@(if home `("-d" ,home) '())
                ,@(if shell `("-s" ,shell) '())
                ,name)))
    (zero? (apply system* "usermod" args))))

(define* (delete-user name #:key (log-port (current-error-port)))
  "Remove user account NAME.  Return #t on success.  This may fail if NAME is
logged in."
  (format log-port "deleting user '~a'...~%" name)
  (zero? (system* "userdel" name)))

(define* (delete-group name #:key (log-port (current-error-port)))
  "Remove group NAME.  Return #t on success."
  (format log-port "deleting group '~a'...~%" name)
  (zero? (system* "groupdel" name)))

(define* (ensure-user name group
                      #:key uid comment home create-home?
                      shell password system?
                      (supplementary-groups '())
                      (log-port (current-error-port))
                      #:rest rest)
  "Make sure user NAME exists and has the relevant settings."
  (if (false-if-exception (getpwnam name))
      (apply modify-user name group rest)
      (apply add-user name group rest)))

(define (activate-users+groups users groups)
  "Make sure the accounts listed in USERS and the user groups listed in GROUPS
are all available.

Each item in USERS is a list of all the characteristics of a user account;
each item in GROUPS is a tuple with the group name, group password or #f, and
numeric gid or #f."
  (define (touch file)
    (close-port (open-file file "a0b")))

  (define activate-user
    (match-lambda
     ((name uid group supplementary-groups comment home create-home?
       shell password system?)
      (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
                                        name)))
        (ensure-user name group
                     #:uid uid
                     #:system? system?
                     #:supplementary-groups supplementary-groups
                     #:comment comment
                     #:home home

                     ;; Home directories of non-system accounts are created by
                     ;; 'activate-user-home'.
                     #:create-home? (and create-home? system?)

                     #:shell shell
                     #:password password)

        (unless system?
          ;; Create the profile directory for the new account.
          (let ((pw (getpwnam name)))
            (mkdir-p profile-dir)
            (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))

  ;; 'groupadd' aborts if the file doesn't already exist.
  (touch "/etc/group")

  ;; Allow home directories to be created under /var/lib.
  (mkdir-p "/var/lib")

  ;; Create the root account so we can use 'useradd' and 'groupadd'.
  (activate-user (find (match-lambda
                        ((name (? zero?) _ ...) #t)
                        (_ #f))
                       users))

  ;; Then create the groups.
  (for-each (match-lambda
             ((name password gid system?)
              (unless (false-if-exception (getgrnam name))
                (add-group name
                           #:gid gid #:password password
                           #:system? system?))))
            groups)

  ;; Create the other user accounts.
  (for-each activate-user users)

  ;; Finally, delete extra user accounts and groups.
  (for-each delete-user
            (lset-difference string=?
                             (map passwd:name (current-users))
                             (match users
                               (((names . _) ...)
                                names))))
  (for-each delete-group
            (lset-difference string=?
                             (map group:name (current-groups))
                             (match groups
                               (((names . _) ...)
                                names)))))

(define (activate-user-home users)
  "Create and populate the home directory of USERS, a list of tuples, unless
they already exist."
  (define ensure-user-home
    (match-lambda
      ((name uid group supplementary-groups comment home create-home?
             shell password system?)
       ;; The home directories of system accounts are created during
       ;; activation, not here.
       (unless (or (not home) (not create-home?) system?
                   (directory-exists? home))
         (let* ((pw  (getpwnam name))
                (uid (passwd:uid pw))
                (gid (passwd:gid pw)))
           (mkdir-p home)
           (chown home uid gid)
           (unless system?
             (copy-account-skeletons home
                                     #:uid uid #:gid gid)))))))

  (for-each ensure-user-home users))

(define (activate-etc etc)
  "Install ETC, a directory in the store, as the source of static files for
/etc."

  ;; /etc is a mixture of static and dynamic settings.  Here is where we
  ;; initialize it from the static part.

  (define (rm-f file)
    (false-if-exception (delete-file file)))

  (format #t "populating /etc from ~a...~%" etc)
  (mkdir-p "/etc")

  ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink.  This
  ;; symlink, to a target outside of the store, probably doesn't belong in the
  ;; static 'etc' store directory.  However, if it were to be put there,
  ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
  ;; time of activation (e.g. when installing a fresh system), the call to
  ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
  (rm-f "/etc/ssl")
  (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")

  (rm-f "/etc/static")
  (symlink etc "/etc/static")
  (for-each (lambda (file)
              (let ((target (string-append "/etc/" file))
                    (source (string-append "/etc/static/" file)))
                (rm-f target)

                ;; Things such as /etc/sudoers must be regular files, not
                ;; symlinks; furthermore, they could be modified behind our
                ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
                ;; symlinking them.
                (if (file-is-directory? source)
                    (symlink source target)
                    (copy-file source target))

                ;; XXX: Dirty hack to meet sudo's expectations.
                (when (string=? (basename target) "sudoers")
                  (chmod target #o440))))
            (scandir etc (negate dot-or-dot-dot?)

                     ;; The default is 'string-locale<?', but we don't have
                     ;; it when run from the initrd's statically-linked
                     ;; Guile.
                     string<?)))

(define %setuid-directory
  ;; Place where setuid programs are stored.
  "/run/setuid-programs")

(define (activate-setuid-programs programs)
  "Turn PROGRAMS, a list of file names, into setuid programs stored under
%SETUID-DIRECTORY."
  (define (make-setuid-program prog)
    (let ((target (string-append %setuid-directory
                                 "/" (basename prog))))
      (copy-file prog target)
      (chown target 0 0)
      (chmod target #o6555)))

  (format #t "setting up setuid programs in '~a'...~%"
          %setuid-directory)
  (if (file-exists? %setuid-directory)
      (for-each (compose delete-file
                         (cut string-append %setuid-directory "/" <>))
                (scandir %setuid-directory
                         (lambda (file)
                           (not (member file '("." ".."))))
                         string<?))
      (mkdir-p %setuid-directory))

  (for-each make-setuid-program programs))

(define (activate-special-files special-files)
  "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
is a pair where the first element is the name of the special file and the
second element is the name it should appear at, such as:

  ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
   (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
"
  (define install-special-file
    (match-lambda
      ((target file)
       (let ((pivot (string-append target ".new")))
         (mkdir-p (dirname target))
         (symlink file pivot)
         (rename-file pivot target)))))

  (for-each install-special-file special-files))

(define (activate-modprobe modprobe)
  "Tell the kernel to use MODPROBE to load modules."
  (call-with-output-file "/proc/sys/kernel/modprobe"
    (lambda (port)
      (display modprobe port))))

(define (activate-firmware directory)
  "Tell the kernel to look for device firmware under DIRECTORY.  This
mechanism bypasses udev: it allows Linux to handle firmware loading directly
by itself, without having to resort to a \"user helper\"."
  (call-with-output-file "/sys/module/firmware_class/parameters/path"
    (lambda (port)
      (display directory port))))

(define (activate-ptrace-attach)
  "Allow users to PTRACE_ATTACH their own processes.

This works around a regression introduced in the default \"security\" policy
found in Linux 3.4 onward that prevents users from attaching to their own
processes--see Yama.txt in the Linux source tree for the rationale.  This
sounds like an unacceptable restriction for little or no security
improvement."
  (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
    (when (file-exists? file)
      (call-with-output-file file
        (lambda (port)
          (display 0 port))))))

(define %current-system
  ;; The system that is current (a symlink.)  This is not necessarily the same
  ;; as the system we booted (aka. /run/booted-system) because we can re-build
  ;; a new system configuration and activate it, without rebooting.
  "/run/current-system")

(define (boot-time-system)
  "Return the '--system' argument passed on the kernel command line."
  (find-long-option "--system" (linux-command-line)))

(define* (activate-current-system
          #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
                                 (boot-time-system))))
  "Atomically make SYSTEM the current system."
  ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
  ;; system reconfigure' to pass the file name of the new system.

  (format #t "making '~a' the current system...~%" system)

  ;; Atomically make SYSTEM current.
  (let ((new (string-append %current-system ".new")))
    (symlink system new)
    (rename-file new %current-system)))

;;; activation.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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 build bootloader)
  #:use-module (ice-9 binary-ports)
  #:export (write-file-on-device))

;;;
;;; Writing utils.
;;;

(define (write-file-on-device file size device offset)
  "Write SIZE bytes from FILE to DEVICE starting at OFFSET."
  (call-with-input-file file
    (lambda (input)
      (let ((bv (get-bytevector-n input size)))
        (call-with-output-file device
          (lambda (output)
            (seek output offset SEEK_SET)
            (put-bytevector output bv))
          #:binary #t)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016 Manolis Fragkiskos Ragkousis <manolis837@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 build cross-toolchain)
  #:use-module (guix build utils)
  #:use-module (guix build gnu-build-system)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:export (cross-gcc-build-phases))

;;; Commentary:
;;;
;;; This module provides tools to build a cross-compiler.
;;;
;;; Code:

(define %gcc-include-paths
  ;; Environment variables for header search paths.
  ;; Note: See <http://bugs.gnu.org/22186> for why not 'CPATH'.
  '("C_INCLUDE_PATH"
    "CPLUS_INCLUDE_PATH"
    "OBJC_INCLUDE_PATH"
    "OBJCPLUS_INCLUDE_PATH"))

(define %gcc-cross-include-paths
  ;; Search path for target headers when cross-compiling.
  (map (cut string-append "CROSS_" <>) %gcc-include-paths))

(define* (make-cross-binutils-visible #:key outputs inputs target
                                      #:allow-other-keys)
  "Create symlinks for 'as', 'nm', and 'ld' in the \"out\" output, under
libexec/gcc, so that the cross-GCC can find them."
  (let* ((out      (assoc-ref outputs "out"))
         (libexec  (string-append out "/libexec/gcc/" target))
         (binutils (string-append (assoc-ref inputs "binutils-cross")
                                  "/bin/" target "-"))
         (wrapper  (string-append (assoc-ref inputs "ld-wrapper-cross")
                                  "/bin/" target "-ld")))
    (for-each (lambda (file)
                (symlink (string-append binutils file)
                         (string-append libexec "/" file)))
              '("as" "nm"))
    (symlink wrapper (string-append libexec "/ld"))
    #t))

(define* (set-cross-path #:key inputs #:allow-other-keys)
  "Add the cross kernel headers to CROSS_CPATH, and remove them from
C_INCLUDE_PATH et al."
  (match (assoc-ref inputs "libc")
    ((? string? libc)
     (let ((kernel (assoc-ref inputs "xkernel-headers")))
       (define (cross? x)
         ;; Return #t if X is a cross-libc or cross Linux.
         (or (string-prefix? libc x)
             (string-prefix? kernel x)))

       (let ((cpath (string-append libc "/include"
                                   ":" kernel "/include")))
         (for-each (cut setenv <> cpath)
                   %gcc-cross-include-paths))

       (setenv "CROSS_LIBRARY_PATH"
               (string-append libc "/lib:" kernel "/lib")) ;for Hurd's libihash

       (for-each (lambda (var)
                   (and=> (getenv var)
                          (lambda (value)
                            (let* ((path (search-path-as-string->list value))
                                   (native-path (list->search-path-as-string
                                                 (remove cross? path) ":")))
                              (setenv var native-path)))))
                 (cons "LIBRARY_PATH" %gcc-include-paths))
       #t))
    (#f
     ;; We're building the sans-libc cross-compiler, so nothing to do.
     #t)))

(define* (set-cross-path/mingw #:key inputs #:allow-other-keys)
  "Add the cross MinGW headers to CROSS_C_*_INCLUDE_PATH, and remove them from
C_*INCLUDE_PATH."
  (let ((libc (assoc-ref inputs "libc"))
        (gcc (assoc-ref inputs "gcc")))
    (define (cross? x)
      (and libc (string-prefix? libc x)))

    (define (unpacked-mingw-dir)
      (match (scandir "." (lambda (name)
                            (string-contains name "mingw-w64")))
        ((mingw-dir)
         (string-append
          (getcwd) "/" mingw-dir "/mingw-w64-headers"))))

    (if libc
        (let ((cpath (string-append libc "/include"
                                    ":" libc "/i686-w64-mingw32/include")))
          (for-each (cut setenv <> cpath)
                    %gcc-cross-include-paths))

        ;; libc is false, so we are building xgcc-sans-libc.
        ;; Add essential headers from mingw-w64.
        (let ((mingw-source (assoc-ref inputs "mingw-source")))
          (invoke "tar" "xvf" mingw-source)
          (let ((mingw-headers (unpacked-mingw-dir)))
            ;; We need _mingw.h which will gets built from _mingw.h.in by
            ;; mingw-w64's configure.  We cannot configure mingw-w64 until we
            ;; have xgcc-sans-libc; substitute to the rescue.
            (copy-file (string-append mingw-headers "/crt/_mingw.h.in")
                       (string-append mingw-headers "/crt/_mingw.h"))

            (substitute* (string-append mingw-headers "/crt/_mingw.h")
              (("@MINGW_HAS_SECURE_API@")
               "#define MINGW_HAS_SECURE_API 1"))

            (let ((cpath (string-append mingw-headers "/include"
                                        ":" mingw-headers "/crt"
                                        ":" mingw-headers
                                        "/defaults/include")))
              (for-each (cut setenv <> cpath)
                        (cons "CROSS_LIBRARY_PATH"
                              %gcc-cross-include-paths))))))

    (when libc
      (setenv "CROSS_LIBRARY_PATH"
              (string-append libc "/lib"
                             ":" libc "/i686-w64-mingw32/lib")))

    (setenv "CPP" (string-append gcc "/bin/cpp"))
    (for-each (lambda (var)
                (and=> (getenv var)
                       (lambda (value)
                         (let* ((path (search-path-as-string->list
                                       value))
                                (native-path (list->search-path-as-string
                                              (remove cross? path) ":")))
                           (setenv var native-path)))))
              (cons "LIBRARY_PATH" %gcc-include-paths))
    #t))

(define (install-strip . _)
  "Install a stripped GCC."
  ;; Unlike our 'strip' phase, this will do the right thing for
  ;; cross-compilers.
  (invoke "make" "install-strip"))

(define* (cross-gcc-build-phases target
                                 #:optional (phases %standard-phases))
  "Modify PHASES to include everything needed to build a cross-GCC for TARGET,
a target triplet."
  (modify-phases phases
    (add-before 'configure 'set-cross-path
      (if (string-contains target "mingw")
          set-cross-path/mingw
          set-cross-path))
    (add-after 'install 'make-cross-binutils-visible
      (cut make-cross-binutils-visible #:target target <...>))
    (replace 'install install-strip)))

;;; cross-toolchain.scm ends here