nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into staging

master
Ludovic Courtès 2019-01-20 22:12:10 +01:00
parent ad79ae7e2d e5ad2cdf17
commit 3e2d4e69c3
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
243 changed files with 39113 additions and 28623 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
TODO
View File

@ -4,6 +4,7 @@
#+STARTUP: content hidestars
Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
@ -83,3 +84,38 @@ Problems include that current glibc releases do not build on GNU/Hurd.
In addition, there haven’t been stable releases of GNU Mach, MiG, and
Hurd, which would be a pre-condition.
* Installer
** Fix impossibility to restart on error after cow-store has been started
See https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
- Force reboot upon installer failure
- Unshare the installer process
- Run the installer process in a separate namespace
** Partitioning
*** Add RAID support
*** Add more partitioning schemes
The actual schemes are taken from Debian Installer but some are not
implemented yet: like "Separate partitions for /home /var and /tmp".
*** Replace wait page "Partition formating is in progress, please wait"
Create a new waiting page describing what's being done:
[ 20% ]
Running mkfs.ext4 on /dev/sda2 ...
[ 40% ]
Running mkfs.ext4 on /dev/sda3 ...
** Desktop environments
*** Allow for no desktop environments
Propose to choose between "headless server" and "lightweight X11" in a new
page.
*** Add services selection feature
Add a services page to the configuration. Ask for services to be installed
like SSH, bluetooth, TLP in a checkbox list?
** Locale and keymap
*** Try to guess user locale and keymap by probing BIOS or HW (dmidecode)
** Timezone
*** Regroup everything in one single page
Under the form:
(UTC + 1) Europe/Paris
(UTC + 2) Africa/Cairo
...

15
configure.ac
View File

@ -135,6 +135,21 @@ if test "x$have_guile_gcrypt" != "xyes"; then
AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
fi
dnl Guile-newt is used by the graphical installer.
GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
AC_ARG_ENABLE([installer],
AS_HELP_STRING([--enable-installer], [Build the graphical installer sources.]))
AS_IF([test "x$enable_installer" = "xyes"], [
if test "x$have_guile_newt" != "xyes"; then
AC_MSG_ERROR([Guile-newt could not be found; please install it.])
fi
])
AM_CONDITIONAL([ENABLE_INSTALLER],
[test "x$enable_installer" = "xyes"])
dnl Make sure we have a full-fledged Guile.
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])

114
doc/guix.texi
View File

@ -9328,12 +9328,20 @@ GuixSD in a virtual machine (VM).
@subsection Preparing for Installation
Once you have successfully booted your computer using the installation medium,
you should end up with a root prompt. Several console TTYs are configured
and can be used to run commands as root. TTY2 shows this documentation,
browsable using the Info reader commands (@pxref{Top,,, info-stnd,
Stand-alone GNU Info}). The installation system runs the GPM mouse
daemon, which allows you to select text with the left mouse button and
to paste it with the middle button.
you should end up with the welcome page of the graphical installer. The
graphical installer is a text-based user interface built upon the newt
library. It shall guide you through all the different steps needed to install
GNU GuixSD. However, as the graphical installer is still under heavy
development, you might want to fallback to the original, shell based install
process, by switching to TTYs 3 to 6 with the shortcuts CTRL-ALT-F[3-6]. The
following sections describe the installation procedure assuming you're using
one of those TTYs. They are configured and can be used to run commands as
root.
TTY2 shows this documentation, browsable using the Info reader commands
(@pxref{Top,,, info-stnd, Stand-alone GNU Info}). The installation system
runs the GPM mouse daemon, which allows you to select text with the left mouse
button and to paste it with the middle button.
@quotation Note
Installation requires access to the Internet so that any missing
@ -9660,12 +9668,12 @@ unless your configuration specifies otherwise
(@pxref{user-account-password, user account passwords}).
@cindex upgrading GuixSD
From then on, you can update GuixSD whenever you want by running
@command{guix pull} as @code{root} (@pxref{Invoking guix pull}), and
then running @command{guix system reconfigure} to build a new system
generation with the latest packages and services (@pxref{Invoking guix
system}). We recommend doing that regularly so that your system
includes the latest security updates (@pxref{Security Updates}).
From then on, you can update GuixSD whenever you want by running @command{guix
pull} as @code{root} (@pxref{Invoking guix pull}), and then running
@command{guix system reconfigure /etc/config.scm}, as @code{root} too, to
build a new system generation with the latest packages and services
(@pxref{Invoking guix system}). We recommend doing that regularly so that
your system includes the latest security updates (@pxref{Security Updates}).
Join us on @code{#guix} on the Freenode IRC network or on
@email{guix-devel@@gnu.org} to share your experience---good or not so
@ -10848,7 +10856,9 @@ system, you will want to append services to @var{%base-services}, like
this:
@example
(cons* (avahi-service) (lsh-service) %base-services)
(cons* (service avahi-service-type)
(service openssh-service-type)
%base-services)
@end example
@end defvr
@ -12634,6 +12644,19 @@ This is a symbol specifying the logging level: @code{quiet}, @code{fatal},
@code{error}, @code{info}, @code{verbose}, @code{debug}, etc. See the man
page for @file{sshd_config} for the full list of level names.
@item @code{extra-content} (default: @code{""})
This field can be used to append arbitrary text to the configuration file. It
is especially useful for elaborate configurations that cannot be expressed
otherwise. This configuration, for example, would generally disable root
logins, but permit them from one specific IP address:
@example
(openssh-configuration
(extra-content "\
Match Address 192.168.0.1
PermitRootLogin yes"))
@end example
@end table
@end deftp
@ -12709,31 +12732,54 @@ browsers, from accessing Facebook.
The @code{(gnu services avahi)} provides the following definition.
@deffn {Scheme Procedure} avahi-service [#:avahi @var{avahi}] @
[#:host-name #f] [#:publish? #t] [#:ipv4? #t] @
[#:ipv6? #t] [#:wide-area? #f] @
[#:domains-to-browse '()] [#:debug? #f]
Return a service that runs @command{avahi-daemon}, a system-wide
@defvr {Scheme Variable} avahi-service-type
This is the service that runs @command{avahi-daemon}, a system-wide
mDNS/DNS-SD responder that allows for service discovery and
"zero-configuration" host name lookups (see @uref{http://avahi.org/}), and
extends the name service cache daemon (nscd) so that it can resolve
@code{.local} host names using
@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. Additionally,
add the @var{avahi} package to the system profile so that commands such as
@command{avahi-browse} are directly usable.
``zero-configuration'' host name lookups (see @uref{http://avahi.org/}).
Its value must be a @code{zero-configuration} record---see below.
If @var{host-name} is different from @code{#f}, use that as the host name to
This service extends the name service cache daemon (nscd) so that it can
resolve @code{.local} host names using
@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. @xref{Name
Service Switch}, for information on host name resolution.
Additionally, add the @var{avahi} package to the system profile so that
commands such as @command{avahi-browse} are directly usable.
@end defvr
@deftp {Data Type} avahi-configuration
Data type representation the configuration for Avahi.
@table @asis
@item @code{host-name} (default: @code{#f})
If different from @code{#f}, use that as the host name to
publish for this machine; otherwise, use the machine's actual host name.
When @var{publish?} is true, publishing of host names and services is allowed;
in particular, avahi-daemon will publish the machine's host name and IP
address via mDNS on the local network.
@item @code{publish?} (default: @code{#t})
When true, allow host names and services to be published (broadcast) over the
network.
When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled.
@item @code{publish-workstation?} (default: @code{#t})
When true, @command{avahi-daemon} publishes the machine's host name and IP
address via mDNS on the local network. To view the host names published on
your local network, you can run:
Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6
sockets.
@end deffn
@example
avahi-browse _workstation._tcp
@end example
@item @code{wide-area?} (default: @code{#f})
When true, DNS-SD over unicast DNS is enabled.
@item @code{ipv4?} (default: @code{#t})
@itemx @code{ipv6?} (default: @code{#t})
These fields determine whether to use IPv4/IPv6 sockets.
@item @code{domains-to-browse} (default: @code{'()})
This is a list of domains to browse.
@end table
@end deftp
@deffn {Scheme Variable} openvswitch-service-type
This is the type of the @uref{http://www.openvswitch.org, Open vSwitch}
@ -22339,8 +22385,8 @@ want is to have @code{.local} host lookup working.
Note that, in this case, in addition to setting the
@code{name-service-switch} of the @code{operating-system} declaration,
you also need to use @code{avahi-service} (@pxref{Networking Services,
@code{avahi-service}}), or @var{%desktop-services}, which includes it
you also need to use @code{avahi-service-type} (@pxref{Networking Services,
@code{avahi-service-type}}), or @var{%desktop-services}, which includes it
(@pxref{Desktop Services}). Doing this makes @code{nss-mdns} accessible
to the name service cache daemon (@pxref{Base Services,
@code{nscd-service}}).

13
gnu/bootloader.scm
View File

@ -105,9 +105,7 @@
bootloader-configuration make-bootloader-configuration
bootloader-configuration?
(bootloader bootloader-configuration-bootloader) ; <bootloader>
(device bootloader-configuration-device ; string
(default #f))
(target %bootloader-configuration-target ; string
(target bootloader-configuration-target ; string
(default #f))
(menu-entries bootloader-configuration-menu-entries ; list of <boot-parameters>
(default '()))
@ -128,15 +126,6 @@
(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.

14
gnu/build/file-systems.scm
View File

@ -42,6 +42,10 @@
find-partition-by-luks-uuid
canonicalize-device-spec
read-partition-label
read-partition-uuid
read-luks-partition-uuid
bind-mount
mount-flags->bit-mask
@ -435,6 +439,12 @@ partition field reader that returned a value."
(define read-partition-uuid
(cut read-partition-field <> %partition-uuid-readers))
(define luks-partition-field-reader
(partition-field-reader read-luks-header luks-header-uuid))
(define read-luks-partition-uuid
(cut read-partition-field <> (list luks-partition-field-reader)))
(define (partition-predicate reader =)
"Return a predicate that returns true if the FIELD of partition header that
was READ is = to the given value."
@ -451,9 +461,7 @@ was READ is = to the given value."
(partition-predicate read-partition-uuid uuid=?))
(define luks-partition-uuid-predicate
(partition-predicate
(partition-field-reader read-luks-header luks-header-uuid)
uuid=?))
(partition-predicate luks-partition-field-reader uuid=?))
(define (find-partition predicate)
"Return the first partition found that matches PREDICATE, or #f if none

65
gnu/ci.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
@ -24,7 +24,9 @@
#:use-module (guix grafts)
#:use-module (guix profiles)
#:use-module (guix packages)
#:use-module (guix channels)
#:use-module (guix derivations)
#:use-module (guix build-system)
#:use-module (guix monads)
#:use-module (guix ui)
#:use-module ((guix licenses)
@ -188,8 +190,40 @@ system.")
"iso9660"))))))
'()))
(define (system-test-jobs store system)
(define channel-build-system
;; Build system used to "convert" a channel instance to a package.
(let* ((build (lambda* (store name inputs
#:key instance #:allow-other-keys)
(run-with-store store
(channel-instances->derivation (list instance)))))
(lower (lambda* (name #:key system instance #:allow-other-keys)
(bag
(name name)
(system system)
(build build)
(arguments `(#:instance ,instance))))))
(build-system (name 'channel)
(description "Turn a channel instance into a package.")
(lower lower))))
(define (channel-instance->package instance)
"Return a package for the given channel INSTANCE."
(package
(inherit guix)
(version (or (string-take (channel-instance-commit instance) 7)
(string-append (package-version guix) "+")))
(build-system channel-build-system)
(arguments `(#:instance ,instance))
(inputs '())
(native-inputs '())
(propagated-inputs '())))
(define* (system-test-jobs store system
#:key source commit)
"Return a list of jobs for the system tests."
(define instance
(checkout->channel-instance source #:commit commit))
(define (test->thunk test)
(lambda ()
(define drv
@ -217,7 +251,13 @@ system.")
(cons name (test->thunk test))))
(if (member system %guixsd-supported-systems)
(map ->job (all-system-tests))
;; Override the value of 'current-guix' used by system tests. Using a
;; channel instance makes tests that rely on 'current-guix' less
;; expensive. It also makes sure we get a valid Guix package when this
;; code is not running from a checkout.
(parameterize ((current-guix-package
(channel-instance->package instance)))
(map ->job (all-system-tests)))
'()))
(define (tarball-jobs store system)
@ -343,6 +383,21 @@ valid."
((lst ...) lst)
((? string? str) (call-with-input-string str read))))
(define checkout
;; Extract metadata about the 'guix' checkout. Its key in ARGUMENTS may
;; vary, so pick up the first one that's neither 'subset' nor 'systems'.
(any (match-lambda
((key . value)
(and (not (memq key '(systems subset)))
value)))
arguments))
(define commit
(assq-ref checkout 'revision))
(define source
(assq-ref checkout 'file-name))
(define (cross-jobs system)
(define (from-32-to-64? target)
;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
@ -405,7 +460,9 @@ valid."
system))))
(append (filter-map job all)
(qemu-jobs store system)
(system-test-jobs store system)
(system-test-jobs store system
#:source source
#:commit commit)
(tarball-jobs store system)
(cross-jobs system))))
((core)

358
gnu/installer.scm Normal file
View File

@ -0,0 +1,358 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer)
#:use-module (guix discovery)
#:use-module (guix packages)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix utils)
#:use-module (guix ui)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages connman)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages disk)
#:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages iso-codes)
#:use-module (gnu packages linux)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages package-management)
#:use-module (gnu packages xorg)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (installer-program))
(define not-config?
;; Select (guix …) and (gnu …) modules, except (guix config).
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define* (build-compiled-file name locale-builder)
"Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
its result in the scheme file NAME. The derivation will also build a compiled
version of this file."
(define set-utf8-locale
#~(begin
(setenv "LOCPATH"
#$(file-append glibc-utf8-locales "/lib/locale/"
(version-major+minor
(package-version glibc-utf8-locales))))
(setlocale LC_ALL "en_US.utf8")))
(define builder
(with-extensions (list guile-json)
(with-imported-modules (source-module-closure
'((gnu installer locale)))
#~(begin
(use-modules (gnu installer locale))
;; The locale files contain non-ASCII characters.
#$set-utf8-locale
(mkdir #$output)
(let ((locale-file
(string-append #$output "/" #$name ".scm"))
(locale-compiled-file
(string-append #$output "/" #$name ".go")))
(call-with-output-file locale-file
(lambda (port)
(write #$locale-builder port)))
(compile-file locale-file
#:output-file locale-compiled-file))))))
(computed-file name builder))
(define apply-locale
;; Install the specified locale.
#~(lambda (locale-name)
(false-if-exception
(setlocale LC_ALL locale-name))))
(define* (compute-locale-step #:key
locales-name
iso639-languages-name
iso3166-territories-name)
"Return a gexp that run the locale-page of INSTALLER, and install the
selected locale. The list of locales, languages and territories passed to
locale-page are computed in derivations named respectively LOCALES-NAME,
ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled,
so that when the installer is run, all the lengthy operations have already
been performed at build time."
(define (compiled-file-loader file name)
#~(load-compiled
(string-append #$file "/" #$name ".go")))
(let* ((supported-locales #~(supported-locales->locales
#$(local-file "installer/aux-files/SUPPORTED")))
(iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/"))
(iso639-3 #~(string-append #$iso-codes "iso_639-3.json"))
(iso639-5 #~(string-append #$iso-codes "iso_639-5.json"))
(iso3166 #~(string-append #$iso-codes "iso_3166-1.json"))
(locales-file (build-compiled-file
locales-name
#~`(quote ,#$supported-locales)))
(iso639-file (build-compiled-file
iso639-languages-name
#~`(quote ,(iso639->iso639-languages
#$supported-locales
#$iso639-3 #$iso639-5))))
(iso3166-file (build-compiled-file
iso3166-territories-name
#~`(quote ,(iso3166->iso3166-territories #$iso3166))))
(locales-loader (compiled-file-loader locales-file
locales-name))
(iso639-loader (compiled-file-loader iso639-file
iso639-languages-name))
(iso3166-loader (compiled-file-loader iso3166-file
iso3166-territories-name)))
#~(lambda (current-installer)
(let ((result
((installer-locale-page current-installer)
#:supported-locales #$locales-loader
#:iso639-languages #$iso639-loader
#:iso3166-territories #$iso3166-loader)))
(#$apply-locale result)
result))))
(define apply-keymap
;; Apply the specified keymap. Use the default keyboard model.
#~(match-lambda
((layout variant)
(kmscon-update-keymap (default-keyboard-model)
layout variant))))
(define* (compute-keymap-step)
"Return a gexp that runs the keymap-page of INSTALLER and install the
selected keymap."
#~(lambda (current-installer)
(let ((result
(call-with-values
(lambda ()
(xkb-rules->models+layouts
(string-append #$xkeyboard-config
"/share/X11/xkb/rules/base.xml")))
(lambda (models layouts)
((installer-keymap-page current-installer)
layouts)))))
(#$apply-keymap result))))
(define (installer-steps)
(let ((locale-step (compute-locale-step
#:locales-name "locales"
#:iso639-languages-name "iso639-languages"
#:iso3166-territories-name "iso3166-territories"))
(keymap-step (compute-keymap-step))
(timezone-data #~(string-append #$tzdata
"/share/zoneinfo/zone.tab")))
#~(lambda (current-installer)
(list
;; Welcome the user and ask him to choose between manual
;; installation and graphical install.
(installer-step
(id 'welcome)
(compute (lambda _
((installer-welcome-page current-installer)
#$(local-file "installer/aux-files/logo.txt")))))
;; Ask the user to choose a locale among those supported by
;; the glibc. Install the selected locale right away, so that
;; the user may benefit from any available translation for the
;; installer messages.
(installer-step
(id 'locale)
(description (G_ "Locale"))
(compute (lambda _
(#$locale-step current-installer)))
(configuration-formatter locale->configuration))
;; Ask the user to select a timezone under glibc format.
(installer-step
(id 'timezone)
(description (G_ "Timezone"))
(compute (lambda _
((installer-timezone-page current-installer)
#$timezone-data)))
(configuration-formatter posix-tz->configuration))
;; The installer runs in a kmscon virtual terminal where loadkeys
;; won't work. kmscon uses libxkbcommon as a backend for keyboard
;; input. It is possible to update kmscon current keymap by sending it
;; a keyboard model, layout and variant, in a somehow similar way as
;; what is done with setxkbmap utility.
;;
;; So ask for a keyboard model, layout and variant to update the
;; current kmscon keymap.
(installer-step
(id 'keymap)
(description (G_ "Keyboard mapping selection"))
(compute (lambda _
(#$keymap-step current-installer))))
;; Run a partitioning tool allowing the user to modify
;; partition tables, partitions and their mount points.
(installer-step
(id 'partition)
(description (G_ "Partitioning"))
(compute (lambda _
((installer-partition-page current-installer))))
(configuration-formatter user-partitions->configuration))
;; Ask the user to input a hostname for the system.
(installer-step
(id 'hostname)
(description (G_ "Hostname"))
(compute (lambda _
((installer-hostname-page current-installer))))
(configuration-formatter hostname->configuration))
;; Provide an interface above connmanctl, so that the user can select
;; a network susceptible to acces Internet.
(installer-step
(id 'network)
(description (G_ "Network selection"))
(compute (lambda _
((installer-network-page current-installer)))))
;; Prompt for users (name, group and home directory).
(installer-step
(id 'user)
(description (G_ "User creation"))
(compute (lambda _
((installer-user-page current-installer))))
(configuration-formatter users->configuration))
;; Ask the user to choose one or many desktop environment(s).
(installer-step
(id 'services)
(description (G_ "Services"))
(compute (lambda _
((installer-services-page current-installer))))
(configuration-formatter
desktop-environments->configuration))
(installer-step
(id 'final)
(description (G_ "Configuration file"))
(compute
(lambda (result prev-steps)
((installer-final-page current-installer)
result prev-steps))))))))
(define (installer-program)
"Return a file-like object that runs the given INSTALLER."
(define init-gettext
;; Initialize gettext support, so that installer messages can be
;; translated.
#~(begin
(bindtextdomain "guix" (string-append #$guix "/share/locale"))
(textdomain "guix")))
(define set-installer-path
;; Add the specified binary to PATH for later use by the installer.
#~(let* ((inputs
'#$(append (list bash ;start subshells
connman ;call connmanctl
cryptsetup
dosfstools ;mkfs.fat
e2fsprogs ;mkfs.ext4
kbd ;chvt
guix ;guix system init call
util-linux ;mkwap
shadow)
(map canonical-package (list coreutils)))))
(with-output-to-port (%make-void-port "w")
(lambda ()
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
(define steps (installer-steps))
(define modules
(scheme-modules*
(string-append (current-source-directory) "/..")
"gnu/installer"))
(define installer-builder
(with-extensions (list guile-gcrypt guile-newt
guile-parted guile-bytestructures
guile-json)
(with-imported-modules `(,@(source-module-closure
`(,@modules
(guix build utils))
#:select? not-config?)
((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (gnu installer record)
(gnu installer keymap)
(gnu installer steps)
(gnu installer final)
(gnu installer hostname)
(gnu installer locale)
(gnu installer parted)
(gnu installer services)
(gnu installer timezone)
(gnu installer user)
(gnu installer newt)
(guix i18n)
(guix build utils)
(ice-9 match))
;; Initialize gettext support so that installers can use
;; (guix i18n) module.
#$init-gettext
;; Add some binaries used by the installers to PATH.
#$set-installer-path
(let* ((current-installer newt-installer)
(steps (#$steps current-installer)))
((installer-init current-installer))
(catch #t
(lambda ()
(run-installer-steps
#:rewind-strategy 'menu
#:menu-proc (installer-menu-page current-installer)
#:steps steps))
(const #f)
(lambda (key . args)
(let ((error-file "/tmp/last-installer-error"))
(call-with-output-file error-file
(lambda (port)
(display-backtrace (make-stack #t) port)
(print-exception port
(stack-ref (make-stack #t) 1)
key args)))
((installer-exit-error current-installer)
error-file key args))
(primitive-exit 1)))
((installer-exit current-installer)))))))
(program-file
"installer"
#~(begin
;; Set the default locale to install unicode support. For
;; some reason, unicode support is not correctly installed
;; when calling this in 'installer-builder'.
(setenv "LANG" "en_US.UTF-8")
(system #$(program-file "installer-real" installer-builder)))))

484
gnu/installer/aux-files/SUPPORTED Normal file
View File

@ -0,0 +1,484 @@
aa_DJ.UTF-8 UTF-8
aa_DJ ISO-8859-1
aa_ER UTF-8
aa_ER@saaho UTF-8
aa_ET UTF-8
af_ZA.UTF-8 UTF-8
af_ZA ISO-8859-1
agr_PE UTF-8
ak_GH UTF-8
am_ET UTF-8
an_ES.UTF-8 UTF-8
an_ES ISO-8859-15
anp_IN UTF-8
ar_AE.UTF-8 UTF-8
ar_AE ISO-8859-6
ar_BH.UTF-8 UTF-8
ar_BH ISO-8859-6
ar_DZ.UTF-8 UTF-8
ar_DZ ISO-8859-6
ar_EG.UTF-8 UTF-8
ar_EG ISO-8859-6
ar_IN UTF-8
ar_IQ.UTF-8 UTF-8
ar_IQ ISO-8859-6
ar_JO.UTF-8 UTF-8
ar_JO ISO-8859-6
ar_KW.UTF-8 UTF-8
ar_KW ISO-8859-6
ar_LB.UTF-8 UTF-8
ar_LB ISO-8859-6
ar_LY.UTF-8 UTF-8
ar_LY ISO-8859-6
ar_MA.UTF-8 UTF-8
ar_MA ISO-8859-6
ar_OM.UTF-8 UTF-8
ar_OM ISO-8859-6
ar_QA.UTF-8 UTF-8
ar_QA ISO-8859-6
ar_SA.UTF-8 UTF-8
ar_SA ISO-8859-6
ar_SD.UTF-8 UTF-8
ar_SD ISO-8859-6
ar_SS UTF-8
ar_SY.UTF-8 UTF-8
ar_SY ISO-8859-6
ar_TN.UTF-8 UTF-8
ar_TN ISO-8859-6
ar_YE.UTF-8 UTF-8
ar_YE ISO-8859-6
ayc_PE UTF-8
az_AZ UTF-8
az_IR UTF-8
as_IN UTF-8
ast_ES.UTF-8 UTF-8
ast_ES ISO-8859-15
be_BY.UTF-8 UTF-8
be_BY CP1251
be_BY@latin UTF-8
bem_ZM UTF-8
ber_DZ UTF-8
ber_MA UTF-8
bg_BG.UTF-8 UTF-8
bg_BG CP1251
bhb_IN.UTF-8 UTF-8
bho_IN UTF-8
bho_NP UTF-8
bi_VU UTF-8
bn_BD UTF-8
bn_IN UTF-8
bo_CN UTF-8
bo_IN UTF-8
br_FR.UTF-8 UTF-8
br_FR ISO-8859-1
br_FR@euro ISO-8859-15
brx_IN UTF-8
bs_BA.UTF-8 UTF-8
bs_BA ISO-8859-2
byn_ER UTF-8
ca_AD.UTF-8 UTF-8
ca_AD ISO-8859-15
ca_ES.UTF-8 UTF-8
ca_ES ISO-8859-1
ca_ES@euro ISO-8859-15
ca_ES@valencia UTF-8
ca_FR.UTF-8 UTF-8
ca_FR ISO-8859-15
ca_IT.UTF-8 UTF-8
ca_IT ISO-8859-15
ce_RU UTF-8
chr_US UTF-8
cmn_TW UTF-8
crh_UA UTF-8
cs_CZ.UTF-8 UTF-8
cs_CZ ISO-8859-2
csb_PL UTF-8
cv_RU UTF-8
cy_GB.UTF-8 UTF-8
cy_GB ISO-8859-14
da_DK.UTF-8 UTF-8
da_DK ISO-8859-1
de_AT.UTF-8 UTF-8
de_AT ISO-8859-1
de_AT@euro ISO-8859-15
de_BE.UTF-8 UTF-8
de_BE ISO-8859-1
de_BE@euro ISO-8859-15
de_CH.UTF-8 UTF-8
de_CH ISO-8859-1
de_DE.UTF-8 UTF-8
de_DE ISO-8859-1
de_DE@euro ISO-8859-15
de_IT.UTF-8 UTF-8
de_IT ISO-8859-1
de_LI.UTF-8 UTF-8
de_LU.UTF-8 UTF-8
de_LU ISO-8859-1
de_LU@euro ISO-8859-15
doi_IN UTF-8
dv_MV UTF-8
dz_BT UTF-8
el_GR.UTF-8 UTF-8
el_GR ISO-8859-7
el_GR@euro ISO-8859-7
el_CY.UTF-8 UTF-8
el_CY ISO-8859-7
en_AG UTF-8
en_AU.UTF-8 UTF-8
en_AU ISO-8859-1
en_BW.UTF-8 UTF-8
en_BW ISO-8859-1
en_CA.UTF-8 UTF-8
en_CA ISO-8859-1
en_DK.UTF-8 UTF-8
en_DK ISO-8859-1
en_GB.UTF-8 UTF-8
en_GB ISO-8859-1
en_HK.UTF-8 UTF-8
en_HK ISO-8859-1
en_IE.UTF-8 UTF-8
en_IE ISO-8859-1
en_IE@euro ISO-8859-15
en_IL UTF-8
en_IN UTF-8
en_NG UTF-8
en_NZ.UTF-8 UTF-8
en_NZ ISO-8859-1
en_PH.UTF-8 UTF-8
en_PH ISO-8859-1
en_SC.UTF-8 UTF-8
en_SG.UTF-8 UTF-8
en_SG ISO-8859-1
en_US.UTF-8 UTF-8
en_US ISO-8859-1
en_ZA.UTF-8 UTF-8
en_ZA ISO-8859-1
en_ZM UTF-8
en_ZW.UTF-8 UTF-8
en_ZW ISO-8859-1
eo UTF-8
es_AR.UTF-8 UTF-8
es_AR ISO-8859-1
es_BO.UTF-8 UTF-8
es_BO ISO-8859-1
es_CL.UTF-8 UTF-8
es_CL ISO-8859-1
es_CO.UTF-8 UTF-8
es_CO ISO-8859-1
es_CR.UTF-8 UTF-8
es_CR ISO-8859-1
es_CU UTF-8
es_DO.UTF-8 UTF-8
es_DO ISO-8859-1
es_EC.UTF-8 UTF-8
es_EC ISO-8859-1
es_ES.UTF-8 UTF-8
es_ES ISO-8859-1
es_ES@euro ISO-8859-15
es_GT.UTF-8 UTF-8
es_GT ISO-8859-1
es_HN.UTF-8 UTF-8
es_HN ISO-8859-1
es_MX.UTF-8 UTF-8
es_MX ISO-8859-1
es_NI.UTF-8 UTF-8
es_NI ISO-8859-1
es_PA.UTF-8 UTF-8
es_PA ISO-8859-1
es_PE.UTF-8 UTF-8
es_PE ISO-8859-1
es_PR.UTF-8 UTF-8
es_PR ISO-8859-1
es_PY.UTF-8 UTF-8
es_PY ISO-8859-1
es_SV.UTF-8 UTF-8
es_SV ISO-8859-1
es_US.UTF-8 UTF-8
es_US ISO-8859-1
es_UY.UTF-8 UTF-8
es_UY ISO-8859-1
es_VE.UTF-8 UTF-8
es_VE ISO-8859-1
et_EE.UTF-8 UTF-8
et_EE ISO-8859-1
et_EE.ISO-8859-15 ISO-8859-15
eu_ES.UTF-8 UTF-8
eu_ES ISO-8859-1
eu_ES@euro ISO-8859-15
fa_IR UTF-8
ff_SN UTF-8
fi_FI.UTF-8 UTF-8
fi_FI ISO-8859-1
fi_FI@euro ISO-8859-15
fil_PH UTF-8
fo_FO.UTF-8 UTF-8
fo_FO ISO-8859-1
fr_BE.UTF-8 UTF-8
fr_BE ISO-8859-1
fr_BE@euro ISO-8859-15
fr_CA.UTF-8 UTF-8
fr_CA ISO-8859-1
fr_CH.UTF-8 UTF-8
fr_CH ISO-8859-1
fr_FR.UTF-8 UTF-8
fr_FR ISO-8859-1
fr_FR@euro ISO-8859-15
fr_LU.UTF-8 UTF-8
fr_LU ISO-8859-1
fr_LU@euro ISO-8859-15
fur_IT UTF-8
fy_NL UTF-8
fy_DE UTF-8
ga_IE.UTF-8 UTF-8
ga_IE ISO-8859-1
ga_IE@euro ISO-8859-15
gd_GB.UTF-8 UTF-8
gd_GB ISO-8859-15
gez_ER UTF-8
gez_ER@abegede UTF-8
gez_ET UTF-8
gez_ET@abegede UTF-8
gl_ES.UTF-8 UTF-8
gl_ES ISO-8859-1
gl_ES@euro ISO-8859-15
gu_IN UTF-8
gv_GB.UTF-8 UTF-8
gv_GB ISO-8859-1
ha_NG UTF-8
hak_TW UTF-8
he_IL.UTF-8 UTF-8
he_IL ISO-8859-8
hi_IN UTF-8
hif_FJ UTF-8
hne_IN UTF-8
hr_HR.UTF-8 UTF-8
hr_HR ISO-8859-2
hsb_DE ISO-8859-2
hsb_DE.UTF-8 UTF-8
ht_HT UTF-8
hu_HU.UTF-8 UTF-8
hu_HU ISO-8859-2
hy_AM UTF-8
hy_AM.ARMSCII-8 ARMSCII-8
ia_FR UTF-8
id_ID.UTF-8 UTF-8
id_ID ISO-8859-1
ig_NG UTF-8
ik_CA UTF-8
is_IS.UTF-8 UTF-8
is_IS ISO-8859-1
it_CH.UTF-8 UTF-8
it_CH ISO-8859-1
it_IT.UTF-8 UTF-8
it_IT ISO-8859-1
it_IT@euro ISO-8859-15
iu_CA UTF-8
ja_JP.EUC-JP EUC-JP
ja_JP.UTF-8 UTF-8
ka_GE.UTF-8 UTF-8
ka_GE GEORGIAN-PS
kab_DZ UTF-8
kk_KZ.UTF-8 UTF-8
kk_KZ PT154
kl_GL.UTF-8 UTF-8
kl_GL ISO-8859-1
km_KH UTF-8
kn_IN UTF-8
ko_KR.EUC-KR EUC-KR
ko_KR.UTF-8 UTF-8
kok_IN UTF-8
ks_IN UTF-8
ks_IN@devanagari UTF-8
ku_TR.UTF-8 UTF-8
ku_TR ISO-8859-9
kw_GB.UTF-8 UTF-8
kw_GB ISO-8859-1
ky_KG UTF-8
lb_LU UTF-8
lg_UG.UTF-8 UTF-8
lg_UG ISO-8859-10
li_BE UTF-8
li_NL UTF-8
lij_IT UTF-8
ln_CD UTF-8
lo_LA UTF-8
lt_LT.UTF-8 UTF-8
lt_LT ISO-8859-13
lv_LV.UTF-8 UTF-8
lv_LV ISO-8859-13
lzh_TW UTF-8
mag_IN UTF-8
mai_IN UTF-8
mai_NP UTF-8
mfe_MU UTF-8
mg_MG.UTF-8 UTF-8
mg_MG ISO-8859-15
mhr_RU UTF-8
mi_NZ.UTF-8 UTF-8
mi_NZ ISO-8859-13
miq_NI UTF-8
mjw_IN UTF-8
mk_MK.UTF-8 UTF-8
mk_MK ISO-8859-5
ml_IN UTF-8
mn_MN UTF-8
mni_IN UTF-8
mr_IN UTF-8
ms_MY.UTF-8 UTF-8
ms_MY ISO-8859-1
mt_MT.UTF-8 UTF-8
mt_MT ISO-8859-3
my_MM UTF-8
nan_TW UTF-8
nan_TW@latin UTF-8
nb_NO.UTF-8 UTF-8
nb_NO ISO-8859-1
nds_DE UTF-8
nds_NL UTF-8
ne_NP UTF-8
nhn_MX UTF-8
niu_NU UTF-8
niu_NZ UTF-8
nl_AW UTF-8
nl_BE.UTF-8 UTF-8
nl_BE ISO-8859-1
nl_BE@euro ISO-8859-15
nl_NL.UTF-8 UTF-8
nl_NL ISO-8859-1
nl_NL@euro ISO-8859-15
nn_NO.UTF-8 UTF-8
nn_NO ISO-8859-1
nr_ZA UTF-8
nso_ZA UTF-8
oc_FR.UTF-8 UTF-8
oc_FR ISO-8859-1
om_ET UTF-8
om_KE.UTF-8 UTF-8
om_KE ISO-8859-1
or_IN UTF-8
os_RU UTF-8
pa_IN UTF-8
pa_PK UTF-8
pap_AW UTF-8
pap_CW UTF-8
pl_PL.UTF-8 UTF-8
pl_PL ISO-8859-2
ps_AF UTF-8
pt_BR.UTF-8 UTF-8
pt_BR ISO-8859-1
pt_PT.UTF-8 UTF-8
pt_PT ISO-8859-1
pt_PT@euro ISO-8859-15
quz_PE UTF-8
raj_IN UTF-8
ro_RO.UTF-8 UTF-8
ro_RO ISO-8859-2
ru_RU.KOI8-R KOI8-R
ru_RU.UTF-8 UTF-8
ru_RU ISO-8859-5
ru_UA.UTF-8 UTF-8
ru_UA KOI8-U
rw_RW UTF-8
sa_IN UTF-8
sat_IN UTF-8
sc_IT UTF-8
sd_IN UTF-8
sd_IN@devanagari UTF-8
se_NO UTF-8
sgs_LT UTF-8
shn_MM UTF-8
shs_CA UTF-8
si_LK UTF-8
sid_ET UTF-8
sk_SK.UTF-8 UTF-8
sk_SK ISO-8859-2
sl_SI.UTF-8 UTF-8
sl_SI ISO-8859-2
sm_WS UTF-8
so_DJ.UTF-8 UTF-8
so_DJ ISO-8859-1
so_ET UTF-8
so_KE.UTF-8 UTF-8
so_KE ISO-8859-1
so_SO.UTF-8 UTF-8
so_SO ISO-8859-1
sq_AL.UTF-8 UTF-8
sq_AL ISO-8859-1
sq_MK UTF-8
sr_ME UTF-8
sr_RS UTF-8
sr_RS@latin UTF-8
ss_ZA UTF-8
st_ZA.UTF-8 UTF-8
st_ZA ISO-8859-1
sv_FI.UTF-8 UTF-8
sv_FI ISO-8859-1
sv_FI@euro ISO-8859-15
sv_SE.UTF-8 UTF-8
sv_SE ISO-8859-1
sw_KE UTF-8
sw_TZ UTF-8
szl_PL UTF-8
ta_IN UTF-8
ta_LK UTF-8
tcy_IN.UTF-8 UTF-8
te_IN UTF-8
tg_TJ.UTF-8 UTF-8
tg_TJ KOI8-T
th_TH.UTF-8 UTF-8
th_TH TIS-620
the_NP UTF-8
ti_ER UTF-8
ti_ET UTF-8
tig_ER UTF-8
tk_TM UTF-8
tl_PH.UTF-8 UTF-8
tl_PH ISO-8859-1
tn_ZA UTF-8
to_TO UTF-8
tpi_PG UTF-8
tr_CY.UTF-8 UTF-8
tr_CY ISO-8859-9
tr_TR.UTF-8 UTF-8
tr_TR ISO-8859-9
ts_ZA UTF-8
tt_RU UTF-8
tt_RU@iqtelif UTF-8
ug_CN UTF-8
uk_UA.UTF-8 UTF-8
uk_UA KOI8-U
unm_US UTF-8
ur_IN UTF-8
ur_PK UTF-8
uz_UZ.UTF-8 UTF-8
uz_UZ ISO-8859-1
uz_UZ@cyrillic UTF-8
ve_ZA UTF-8
vi_VN UTF-8
wa_BE ISO-8859-1
wa_BE@euro ISO-8859-15
wa_BE.UTF-8 UTF-8
wae_CH UTF-8
wal_ET UTF-8
wo_SN UTF-8
xh_ZA.UTF-8 UTF-8
xh_ZA ISO-8859-1
yi_US.UTF-8 UTF-8
yi_US CP1255
yo_NG UTF-8
yue_HK UTF-8
yuw_PG UTF-8
zh_CN.GB18030 GB18030
zh_CN.GBK GBK
zh_CN.UTF-8 UTF-8
zh_CN GB2312
zh_HK.UTF-8 UTF-8
zh_HK BIG5-HKSCS
zh_SG.UTF-8 UTF-8
zh_SG.GBK GBK
zh_SG GB2312
zh_TW.EUC-TW EUC-TW
zh_TW.UTF-8 UTF-8
zh_TW BIG5
zu_ZA.UTF-8 UTF-8
zu_ZA ISO-8859-1

19
gnu/installer/aux-files/logo.txt Normal file
View File

@ -0,0 +1,19 @@
░░░ ░░░
░░▒▒░░░░░░░░░ ░░░░░░░░░▒▒░░
░░▒▒▒▒▒░░░░░░░ ░░░░░░░▒▒▒▒▒░
░▒▒▒░░▒▒▒▒▒ ░░░░░░░▒▒░
░▒▒▒▒░ ░░░░░░
▒▒▒▒▒ ░░░░░░
▒▒▒▒▒ ░░░░░
░▒▒▒▒▒ ░░░░░
▒▒▒▒▒ ░░░░░
▒▒▒▒▒ ░░░░░
░▒▒▒▒▒░░░░░
▒▒▒▒▒▒░░░
▒▒▒▒▒▒░
_____ _ _ _ _ _____ _
/ ____| \ | | | | | / ____| (_)
| | __| \| | | | | | | __ _ _ ___ __
| | |_ | . ' | | | | | | |_ | | | | \ \/ /
| |__| | |\ | |__| | | |__| | |_| | |> <
\_____|_| \_|\____/ \_____|\__,_|_/_/\_\

400
gnu/installer/connman.scm Normal file
View File

@ -0,0 +1,400 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer connman)
#:use-module (gnu installer utils)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (<technology>
technology
technology?
technology-name
technology-type
technology-powered?
technology-connected?
<service>
service
service?
service-name
service-type
service-path
service-strength
service-state
&connman-error
connman-error?
connman-error-command
connman-error-output
connman-error-status
&connman-connection-error
connman-connection-error?
connman-connection-error-service
connman-connection-error-output
&connman-password-error
connman-password-error?
&connman-already-connected-error
connman-already-connected-error?
connman-state
connman-technologies
connman-enable-technology
connman-disable-technology
connman-scan-technology
connman-services
connman-connect
connman-disconnect
connman-online?
connman-connect-with-auth))
;;; Commentary:
;;;
;;; This module provides procedures for talking with the connman daemon.
;;; The best approach would have been using connman dbus interface.
;;; However, as Guile dbus bindings are not available yet, the console client
;;; "connmanctl" is used to talk with the daemon.
;;;
;;;
;;; Technology record.
;;;
;; The <technology> record encapsulates the "Technology" object of connman.
;; Technology type will be typically "ethernet", "wifi" or "bluetooth".
(define-record-type* <technology>
technology make-technology
technology?
(name technology-name) ; string
(type technology-type) ; string
(powered? technology-powered?) ; boolean
(connected? technology-connected?)) ; boolean
;;;
;;; Service record.
;;;
;; The <service> record encapsulates the "Service" object of connman.
;; Service type is the same as the technology it is associated to, path is a
;; unique identifier given by connman, strength describes the signal quality
;; if applicable. Finally, state is "idle", "failure", "association",
;; "configuration", "ready", "disconnect" or "online".
(define-record-type* <service>
service make-service
service?
(name service-name) ; string
(type service-type) ; string
(path service-path) ; string
(strength service-strength) ; integer
(state service-state)) ; string
;;;
;;; Condition types.
;;;
(define-condition-type &connman-error &error
connman-error?
(command connman-error-command)
(output connman-error-output)
(status connman-error-status))
(define-condition-type &connman-connection-error &error
connman-connection-error?
(service connman-connection-error-service)
(output connman-connection-error-output))
(define-condition-type &connman-password-error &connman-connection-error
connman-password-error?)
(define-condition-type &connman-already-connected-error
&connman-connection-error connman-already-connected-error?)
;;;
;;; Procedures.
;;;
(define (connman-run command env arguments)
"Run the given COMMAND, with the specified ENV and ARGUMENTS. The error
output is discarded and &connman-error condition is raised if the command
returns a non zero exit code."
(let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null"))
(command-string (string-join command " "))
(pipe (open-input-pipe command-string))
(output (read-lines pipe))
(ret (close-pipe pipe)))
(case (status:exit-val ret)
((0) output)
(else (raise (condition (&connman-error
(command command)
(output output)
(status ret))))))))
(define (connman . arguments)
"Run connmanctl with the specified ARGUMENTS. Set the LANG environment
variable to C because the command output will be parsed and we don't want it
to be translated."
(connman-run "connmanctl" "LANG=C" arguments))
(define (parse-keys keys)
"Parse the given list of strings KEYS, under the following format:
'((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...)
Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2)
...) elements."
(let ((key-regex (make-regexp "([^ ]+) = ([^$]+)")))
(map (lambda (key)
(let ((match-key (regexp-exec key-regex key)))
(cons (match:substring match-key 1)
(match:substring match-key 2))))
keys)))
(define (connman-state)
"Return the state of connman. The nominal states are 'offline, 'idle,
'ready, 'oneline. If an unexpected state is read, 'unknown is
returned. Finally, an error is raised if the comman output could not be
parsed, usually because the connman daemon is not responding."
(let* ((output (connman "state"))
(state-keys (parse-keys output)))
(let ((state (assoc-ref state-keys "State")))
(if state
(cond ((string=? state "offline") 'offline)
((string=? state "idle") 'idle)
((string=? state "ready") 'ready)
((string=? state "online") 'online)
(else 'unknown))
(raise (condition
(&message
(message "Could not determine the state of connman."))))))))
(define (split-technology-list technologies)
"Parse the given strings list TECHNOLOGIES, under the following format:
'((\"/net/connman/technology/xxx\")
(\"KEY = VALUE\")
...
(\"/net/connman/technology/yyy\")
(\"KEY2 = VALUE2\")
...)
Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...))
list so that each keys of a given technology are gathered in a separate list."
(let loop ((result '())
(cur-list '())
(input (reverse technologies)))
(if (null? input)
result
(let ((item (car input)))
(if (string-match "/net/connman/technology" item)
(loop (cons cur-list result) '() (cdr input))
(loop result (cons item cur-list) (cdr input)))))))
(define (string->boolean string)
(equal? string "True"))
(define (connman-technologies)
"Return a list of available <technology> records."
(define (technology-output->technology output)
(let ((keys (parse-keys output)))
(technology
(name (assoc-ref keys "Name"))
(type (assoc-ref keys "Type"))
(powered? (string->boolean (assoc-ref keys "Powered")))
(connected? (string->boolean (assoc-ref keys "Connected"))))))
(let* ((output (connman "technologies"))
(technologies (split-technology-list output)))
(map technology-output->technology technologies)))
(define (connman-enable-technology technology)
"Enable the given TECHNOLOGY."
(let ((type (technology-type technology)))
(connman "enable" type)))
(define (connman-disable-technology technology)
"Disable the given TECHNOLOGY."
(let ((type (technology-type technology)))
(connman "disable" type)))
(define (connman-scan-technology technology)
"Run a scan for the given TECHNOLOGY."
(let ((type (technology-type technology)))
(connman "scan" type)))
(define (connman-services)
"Return a list of available <services> records."
(define (service-output->service path output)
(let* ((service-keys
(match output
((_ . rest) rest)))
(keys (parse-keys service-keys)))
(service
(name (assoc-ref keys "Name"))
(type (assoc-ref keys "Type"))
(path path)
(strength (and=> (assoc-ref keys "Strength") string->number))
(state (assoc-ref keys "State")))))
(let* ((out (connman "services"))
(out-filtered (delete "" out))
(services-path (map (lambda (service)
(match (string-split service #\ )
((_ ... path) path)))
out-filtered))
(services-output (map (lambda (service)
(connman "services" service))
services-path)))
(map service-output->service services-path services-output)))
(define (connman-connect service)
"Connect to the given SERVICE."
(let ((path (service-path service)))
(connman "connect" path)))
(define (connman-disconnect service)
"Disconnect from the given SERVICE."
(let ((path (service-path service)))
(connman "disconnect" path)))
(define (connman-online?)
(let ((state (connman-state)))
(eq? state 'online)))
(define (connman-connect-with-auth service password-proc)
"Connect to the given SERVICE with the password returned by calling
PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
because authentication is done by communicating with an agent.
As the open-pipe procedure of Guile do not allow to read from stderr, we have
to merge stdout and stderr using bash redirection. Then error messages are
extracted from connmanctl output using a regexp. This makes the whole
procedure even more unreliable.
Raise &connman-connection-error if an error occured during connection. Raise
&connman-password-error if the given password is incorrect."
(define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n"))
(define (match-connman-error str)
(let ((match-error (regexp-exec connman-error-regexp str)))
(and match-error (match:substring match-error 1))))
(define* (read-regexps-or-error port regexps error-handler)
"Read characters from port until an error is detected, or one of the given
REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
string as argument. Raise an error if the eof is reached before one of the
regexps is matched."
(let loop ((res ""))
(let ((char (read-char port)))
(cond
((eof-object? char)
(raise (condition
(&message
(message "Unable to find expected regexp.")))))
((match-connman-error res)
=>
(lambda (match)
(error-handler match)))
((or-map (lambda (regexp)
(and (regexp-exec regexp res) regexp))
regexps)
=>
(lambda (match)
match))
(else
(loop (string-append res (string char))))))))
(define* (read-regexp-or-error port regexp error-handler)
"Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP."
(read-regexps-or-error port (list regexp) error-handler))
(define (connman-error->condition path error)
(cond
((string-match "Already connected" error)
(condition (&connman-already-connected-error
(service path)
(output error))))
(else
(condition (&connman-connection-error
(service path)
(output error))))))
(define (run-connection-sequence pipe)
"Run the connection sequence using PIPE as an opened port to an
interactive connmanctl process."
(let* ((path (service-path service))
(error-handler (lambda (error)
(raise
(connman-error->condition path error)))))
;; Start the agent.
(format pipe "agent on\n")
(read-regexp-or-error pipe (make-regexp "Agent registered") error-handler)
;; Let's try to connect to the service. If the service does not require
;; a password, the connection might succeed right after this call.
;; Otherwise, connmanctl will prompt us for a password.
(format pipe "connect ~a\n" path)
(let* ((connected-regexp (make-regexp (format #f "Connected ~a" path)))
(passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*"))
(regexps (list connected-regexp passphrase-regexp))
(result (read-regexps-or-error pipe regexps error-handler)))
;; A password is required.
(when (eq? result passphrase-regexp)
(format pipe "~a~%" (password-proc))
;; Now, we have to wait for the connection to succeed. If an error
;; occurs, it is most likely because the password is incorrect.
;; In that case, we escape from an eventual retry loop that would
;; add complexity to this procedure, and raise a
;; &connman-password-error condition.
(read-regexp-or-error pipe connected-regexp
(lambda (error)
;; Escape from retry loop.
(format pipe "no\n")
(raise
(condition (&connman-password-error
(service path)
(output error))))))))))
;; XXX: Find a better way to read stderr, like with the "subprocess"
;; procedure of racket that return input ports piped on the process stdin and
;; stderr.
(let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH)))
(dynamic-wind
(const #t)
(lambda ()
(run-connection-sequence pipe)
#t)
(lambda ()
(format pipe "quit\n")
(close-pipe pipe)))))

36
gnu/installer/final.scm Normal file
View File

@ -0,0 +1,36 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer final)
#:use-module (gnu installer newt page)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu services herd)
#:use-module (guix build utils)
#:export (install-system))
(define (install-system)
"Start COW-STORE service on target directory and launch guix install command
in a subshell."
(let ((install-command
(format #f "guix system init ~a ~a"
(%installer-configuration-file)
(%installer-target-dir))))
(mkdir-p (%installer-target-dir))
(start-service 'cow-store (list (%installer-target-dir)))
(false-if-exception (run-shell-command install-command))))

23
gnu/installer/hostname.scm Normal file
View File

@ -0,0 +1,23 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer hostname)
#:export (hostname->configuration))
(define (hostname->configuration hostname)
`((host-name ,hostname)))

172
gnu/installer/keymap.scm Normal file
View File

@ -0,0 +1,172 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer keymap)
#:use-module (guix records)
#:use-module (sxml match)
#:use-module (sxml simple)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (<x11-keymap-model>
x11-keymap-model
make-x11-keymap-model
x11-keymap-model?
x11-keymap-model-name
x11-keymap-model-description
<x11-keymap-layout>
x11-keymap-layout
make-x11-keymap-layout
x11-keymap-layout?
x11-keymap-layout-name
x11-keymap-layout-description
x11-keymap-layout-variants
<x11-keymap-variant>
x11-keymap-variant
make-x11-keymap-variant
x11-keymap-variant?
x11-keymap-variant-name
x11-keymap-variant-description
default-keyboard-model
xkb-rules->models+layouts
kmscon-update-keymap))
(define-record-type* <x11-keymap-model>
x11-keymap-model make-x11-keymap-model
x11-keymap-model?
(name x11-keymap-model-name) ;string
(description x11-keymap-model-description)) ;string
(define-record-type* <x11-keymap-layout>
x11-keymap-layout make-x11-keymap-layout
x11-keymap-layout?
(name x11-keymap-layout-name) ;string
(description x11-keymap-layout-description) ;string
(variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
(define-record-type* <x11-keymap-variant>
x11-keymap-variant make-x11-keymap-variant
x11-keymap-variant?
(name x11-keymap-variant-name) ;string
(description x11-keymap-variant-description)) ;string
;; Assume all modern keyboards have this model.
(define default-keyboard-model (make-parameter "pc105"))
(define (xkb-rules->models+layouts file)
"Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
Configuration Database, describing possible XKB configurations."
(define (model m)
(sxml-match m
[(model
(configItem
(name ,name)
(description ,description)
. ,rest))
(x11-keymap-model
(name name)
(description description))]))
(define (variant v)
(sxml-match v
[(variant
;; According to xbd-rules DTD, the definition of a
;; configItem is: <!ELEMENT configItem
;; (name,shortDescription*,description*,vendor?,
;; countryList?,languageList?,hwList?)>
;;
;; shortDescription and description are optional elements
;; but sxml-match does not support default values for
;; elements (only attributes). So to avoid writing as many
;; patterns as existing possibilities, gather all the
;; remaining elements but name in REST-VARIANT.
(configItem
(name ,name)
. ,rest-variant))
(x11-keymap-variant
(name name)
(description (car
(assoc-ref rest-variant 'description))))]))
(define (layout l)
(sxml-match l
[(layout
(configItem
(name ,name)
. ,rest-layout)
(variantList ,[variant -> v] ...))
(x11-keymap-layout
(name name)
(description (car
(assoc-ref rest-layout 'description)))
(variants (list v ...)))]
[(layout
(configItem
(name ,name)
. ,rest-layout))
(x11-keymap-layout
(name name)
(description (car
(assoc-ref rest-layout 'description)))
(variants '()))]))
(let ((sxml (call-with-input-file file
(lambda (port)
(xml->sxml port #:trim-whitespace? #t)))))
(match
(sxml-match sxml
[(*TOP*
,pi
(xkbConfigRegistry
(@ . ,ignored)
(modelList ,[model -> m] ...)
(layoutList ,[layout -> l] ...)
. ,rest))
(list
(list m ...)
(list l ...))])
((models layouts)
(values models layouts)))))
(define (kmscon-update-keymap model layout variant)
"Update kmscon keymap with the provided MODEL, LAYOUT and VARIANT."
(and=>
(getenv "KEYMAP_UPDATE")
(lambda (keymap-file)
(unless (file-exists? keymap-file)
(error "Unable to locate keymap update file"))
;; See file gnu/packages/patches/kmscon-runtime-keymap-switch.patch.
;; This dirty hack makes possible to update kmscon keymap at runtime by
;; writing an X11 keyboard model, layout and variant to a named pipe
;; referred by KEYMAP_UPDATE environment variable.
(call-with-output-file keymap-file
(lambda (port)
(format port model)
(put-u8 port 0)
(format port layout)
(put-u8 port 0)
(format port variant)
(put-u8 port 0))))))

210
gnu/installer/locale.scm Normal file
View File

@ -0,0 +1,210 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer locale)
#:use-module (gnu installer utils)
#:use-module (guix records)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (locale-language
locale-territory
locale-codeset
locale-modifier
locale->locale-string
supported-locales->locales
iso639->iso639-languages
language-code->language-name
iso3166->iso3166-territories
territory-code->territory-name
locale->configuration))
;;;
;;; Locale.
;;;
;; A glibc locale string has the following format:
;; language[_territory[.codeset][@modifier]].
(define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")
;; LOCALE will be better expressed in a (guix record) that in an association
;; list. However, loading large files containing records does not scale
;; well. The same thing goes for ISO639 and ISO3166 association lists used
;; later in this module.
(define (locale-language assoc)
(assoc-ref assoc 'language))
(define (locale-territory assoc)
(assoc-ref assoc 'territory))
(define (locale-codeset assoc)
(assoc-ref assoc 'codeset))
(define (locale-modifier assoc)
(assoc-ref assoc 'modifier))
(define (locale-string->locale string)
"Return the locale association list built from the parsing of STRING."
(let ((matches (string-match locale-regexp string)))
`((language . ,(match:substring matches 1))
(territory . ,(match:substring matches 3))
(codeset . ,(match:substring matches 5))
(modifier . ,(match:substring matches 7)))))
(define (locale->locale-string locale)
"Reverse operation of locale-string->locale."
(let ((language (locale-language locale))
(territory (locale-territory locale))
(codeset (locale-codeset locale))
(modifier (locale-modifier locale)))
(apply string-append
`(,language
,@(if territory
`("_" ,territory)
'())
,@(if codeset
`("." ,codeset)
'())
,@(if modifier
`("@" ,modifier)
'())))))
(define (supported-locales->locales supported-locales)
"Parse the SUPPORTED-LOCALES file from the glibc and return the matching
list of LOCALE association lists."
(call-with-input-file supported-locales
(lambda (port)
(let ((lines (read-lines port)))
(map (lambda (line)
(match (string-split line #\ )
((locale-string codeset)
(let ((line-locale (locale-string->locale locale-string)))
(assoc-set! line-locale 'codeset codeset)))))
lines)))))
;;;
;;; Language.
;;;
(define (iso639-language-alpha2 assoc)
(assoc-ref assoc 'alpha2))
(define (iso639-language-alpha3 assoc)
(assoc-ref assoc 'alpha3))
(define (iso639-language-name assoc)
(assoc-ref assoc 'name))
(define (supported-locale? locales alpha2 alpha3)
"Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
found."
(find (lambda (locale)
(let ((language (locale-language locale)))
(or (and=> alpha2
(lambda (code)
(string=? language code)))
(string=? language alpha3))))
locales))
(define (iso639->iso639-languages locales iso639-3 iso639-5)
"Return a list of ISO639 association lists created from the parsing of
ISO639-3 and ISO639-5 files."
(call-with-input-file iso639-3
(lambda (port-iso639-3)
(call-with-input-file iso639-5
(lambda (port-iso639-5)
(filter-map
(lambda (hash)
(let ((alpha2 (hash-ref hash "alpha_2"))
(alpha3 (hash-ref hash "alpha_3"))
(name (hash-ref hash "name")))
(and (supported-locale? locales alpha2 alpha3)
`((alpha2 . ,alpha2)
(alpha3 . ,alpha3)
(name . ,name)))))
(append
(hash-ref (json->scm port-iso639-3) "639-3")
(hash-ref (json->scm port-iso639-5) "639-5"))))))))
(define (language-code->language-name languages language-code)
"Using LANGUAGES as a list of ISO639 association lists, return the language
name corresponding to the given LANGUAGE-CODE."
(let ((iso639-language
(find (lambda (language)
(or
(and=> (iso639-language-alpha2 language)
(lambda (alpha2)
(string=? alpha2 language-code)))
(string=? (iso639-language-alpha3 language)
language-code)))
languages)))
(iso639-language-name iso639-language)))
;;;
;;; Territory.
;;;
(define (iso3166-territory-alpha2 assoc)
(assoc-ref assoc 'alpha2))
(define (iso3166-territory-alpha3 assoc)
(assoc-ref assoc 'alpha3))
(define (iso3166-territory-name assoc)
(assoc-ref assoc 'name))
(define (iso3166->iso3166-territories iso3166)
"Return a list of ISO3166 association lists created from the parsing of
ISO3166 file."
(call-with-input-file iso3166
(lambda (port)
(map (lambda (hash)
`((alpha2 . ,(hash-ref hash "alpha_2"))
(alpha3 . ,(hash-ref hash "alpha_3"))
(name . ,(hash-ref hash "name"))))
(hash-ref (json->scm port) "3166-1")))))
(define (territory-code->territory-name territories territory-code)
"Using TERRITORIES as a list of ISO3166 association lists return the
territory name corresponding to the given TERRITORY-CODE."
(let ((iso3166-territory
(find (lambda (territory)
(or
(and=> (iso3166-territory-alpha2 territory)
(lambda (alpha2)
(string=? alpha2 territory-code)))
(string=? (iso3166-territory-alpha3 territory)
territory-code)))
territories)))
(iso3166-territory-name iso3166-territory)))
;;;
;;; Configuration formatter.
;;;
(define (locale->configuration locale)
"Return the configuration field for LOCALE."
`((locale ,locale)))

128
gnu/installer/newt.scm Normal file
View File

@ -0,0 +1,128 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt)
#:use-module (gnu installer record)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt ethernet)
#:use-module (gnu installer newt final)
#:use-module (gnu installer newt hostname)
#:use-module (gnu installer newt keymap)
#:use-module (gnu installer newt locale)
#:use-module (gnu installer newt menu)
#:use-module (gnu installer newt network)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt partition)
#:use-module (gnu installer newt services)
#:use-module (gnu installer newt timezone)
#:use-module (gnu installer newt user)
#:use-module (gnu installer newt utils)
#:use-module (gnu installer newt welcome)
#:use-module (gnu installer newt wifi)
#:use-module (guix config)
#:use-module (guix discovery)
#:use-module (guix i18n)
#:use-module (srfi srfi-26)
#:use-module (newt)
#:export (newt-installer))
(define (init)
(newt-init)
(clear-screen)
(set-screen-size!))
(define (exit)
(newt-finish)
(clear-screen))
(define (exit-error file key args)
(newt-set-color COLORSET-ROOT "white" "red")
(let ((width (nearest-exact-integer
(* (screen-columns) 0.8)))
(height (nearest-exact-integer
(* (screen-rows) 0.7))))
(run-file-textbox-page
#:info-text (format #f (G_ "The installer has encountered an unexpected \
problem. The backtrace is displayed below. Please report it by email to \
<~a>.") %guix-bug-report-address)
#:title (G_ "Unexpected problem")
#:file file
#:exit-button? #f
#:info-textbox-width width
#:file-textbox-width width
#:file-textbox-height height))
(newt-set-color COLORSET-ROOT "white" "blue")
(newt-finish)
(clear-screen))
(define (final-page result prev-steps)
(run-final-page result prev-steps))
(define* (locale-page #:key
supported-locales
iso639-languages
iso3166-territories)
(run-locale-page
#:supported-locales supported-locales
#:iso639-languages iso639-languages
#:iso3166-territories iso3166-territories))
(define (timezone-page zonetab)
(run-timezone-page zonetab))
(define (welcome-page logo)
(run-welcome-page logo))
(define (menu-page steps)
(run-menu-page steps))
(define* (keymap-page layouts)
(run-keymap-page layouts))
(define (network-page)
(run-network-page))
(define (hostname-page)
(run-hostname-page))
(define (user-page)
(run-user-page))
(define (partition-page)
(run-partioning-page))
(define (services-page)
(run-services-page))
(define newt-installer
(installer
(name 'newt)
(init init)
(exit exit)
(exit-error exit-error)
(final-page final-page)
(keymap-page keymap-page)
(locale-page locale-page)
(menu-page menu-page)
(network-page network-page)
(timezone-page timezone-page)
(hostname-page hostname-page)
(user-page user-page)
(partition-page partition-page)
(services-page services-page)
(welcome-page welcome-page)))

81
gnu/installer/newt/ethernet.scm Normal file
View File

@ -0,0 +1,81 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt ethernet)
#:use-module (gnu installer connman)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt utils)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (ice-9 format)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-ethernet-page))
(define (ethernet-services)
"Return all the connman services of ethernet type."
(let ((services (connman-services)))
(filter (lambda (service)
(and (string=? (service-type service) "ethernet")
(not (string-null? (service-name service)))))
services)))
(define (ethernet-service->text service)
"Return a string describing the given ethernet SERVICE."
(let* ((name (service-name service))
(path (service-path service))
(full-name (string-append name "-" path))
(state (service-state service))
(connected? (or (string=? state "online")
(string=? state "ready"))))
(format #f "~c ~a~%"
(if connected? #\* #\ )
full-name)))
(define (connect-ethernet-service service)
"Connect to the given ethernet SERVICE. Display a connecting page while the
connection is pending."
(let* ((service-name (service-name service))
(form (draw-connecting-page service-name)))
(connman-connect service)
(destroy-form-and-pop form)
service))
(define (run-ethernet-page)
(let ((services (ethernet-services)))
(if (null? services)
(begin
(run-error-page
(G_ "No ethernet service available, please try again.")
(G_ "No service"))
(raise
(condition
(&installer-step-abort))))
(run-listbox-selection-page
#:info-text (G_ "Please select an ethernet network.")
#:title (G_ "Ethernet connection")
#:listbox-items services
#:listbox-item->text ethernet-service->text
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort))))
#:listbox-callback-procedure connect-ethernet-service))))

86
gnu/installer/newt/final.scm Normal file
View File

@ -0,0 +1,86 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt final)
#:use-module (gnu installer final)
#:use-module (gnu installer parted)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-final-page))
(define (run-config-display-page)
(let ((width (%configuration-file-width))
(height (nearest-exact-integer
(/ (screen-rows) 2))))
(run-file-textbox-page
#:info-text (G_ "We're now ready to proceed with the installation! \
A system configuration file has been generated, it is displayed below. \
The new system will be created from this file once you've pressed OK. \
This will take a few minutes.")
#:title (G_ "Configuration file")
#:file (%installer-configuration-file)
#:info-textbox-width width
#:file-textbox-width width
#:file-textbox-height height
#:exit-button-callback-procedure
(lambda ()
(raise
(condition
(&installer-step-abort)))))))
(define (run-install-success-page)
(message-window
(G_ "Installation complete")
(G_ "Reboot")
(G_ "Congratulations! Installation is now complete. \
You may remove the device containing the installation image and \
press the button to reboot.")))
(define (run-install-failed-page)
(choice-window
(G_ "Installation failed")
(G_ "Restart installer")
(G_ "Retry system install")
(G_ "The final system installation step failed. You can retry the \
last step, or restart the installer.")))
(define (run-install-shell)
(clear-screen)
(newt-suspend)
(let ((install-ok? (install-system)))
(newt-resume)
install-ok?))
(define (run-final-page result prev-steps)
(let* ((configuration (format-configuration prev-steps result))
(user-partitions (result-step result 'partition))
(install-ok?
(with-mounted-partitions
user-partitions
(configuration->file configuration)
(run-config-display-page)
(run-install-shell))))
(if install-ok?
(run-install-success-page)
(run-install-failed-page))))

26
gnu/installer/newt/hostname.scm Normal file
View File

@ -0,0 +1,26 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt hostname)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:export (run-hostname-page))
(define (run-hostname-page)
(run-input-page (G_ "Please enter the system hostname.")
(G_ "Hostname")))

122
gnu/installer/newt/keymap.scm Normal file
View File

@ -0,0 +1,122 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt keymap)
#:use-module (gnu installer keymap)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (guix records)
#:use-module (newt)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (run-keymap-page))
(define (run-layout-page layouts layout->text)
(let ((title (G_ "Layout")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Please choose your keyboard layout.")
#:listbox-items layouts
#:listbox-item->text layout->text
#:sort-listbox-items? #f
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-variant-page variants variant->text)
(let ((title (G_ "Variant")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Please choose a variant for your keyboard layout.")
#:listbox-items variants
#:listbox-item->text variant->text
#:sort-listbox-items? #f
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (sort-layouts layouts)
"Sort LAYOUTS list by putting the US layout ahead and return it."
(call-with-values
(lambda ()
(partition
(lambda (layout)
(let ((name (x11-keymap-layout-name layout)))
(string=? name "us")))
layouts))
(cut append <> <>)))
(define (sort-variants variants)
"Sort VARIANTS list by putting the internation variant ahead and return it."
(call-with-values
(lambda ()
(partition
(lambda (variant)
(let ((name (x11-keymap-variant-name variant)))
(string=? name "altgr-intl")))
variants))
(cut append <> <>)))
(define* (run-keymap-page layouts)
"Run a page asking the user to select a keyboard layout and variant. LAYOUTS
is a list of supported X11-KEYMAP-LAYOUT. Return a list of two elements, the
names of the selected keyboard layout and variant."
(define keymap-steps
(list
(installer-step
(id 'layout)
(compute
(lambda _
(run-layout-page
(sort-layouts layouts)
(lambda (layout)
(x11-keymap-layout-description layout))))))
;; Propose the user to select a variant among those supported by the
;; previously selected layout.
(installer-step
(id 'variant)
(compute
(lambda (result _)
(let* ((layout (result-step result 'layout))
(variants (x11-keymap-layout-variants layout)))
;; Return #f if the layout does not have any variant.
(and (not (null? variants))
(run-variant-page
(sort-variants variants)
(lambda (variant)
(x11-keymap-variant-description
variant))))))))))
(define (format-result result)
(let ((layout (x11-keymap-layout-name
(result-step result 'layout)))
(variant (and=> (result-step result 'variant)
(lambda (variant)
(x11-keymap-variant-name variant)))))
(list layout (or variant ""))))
(format-result
(run-installer-steps #:steps keymap-steps)))

217
gnu/installer/newt/locale.scm Normal file
View File

@ -0,0 +1,217 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt locale)
#:use-module (gnu installer locale)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (newt)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (run-locale-page))
(define (run-language-page languages language->text)
(let ((title (G_ "Locale language")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose the locale's language to be used for the \
installation process. A locale is a regional variant of your language \
encompassing number, date and currency format, among other details.
Based on the language you choose, you will possibly be asked to \
select a locale's territory, codeset and modifier in the next \
steps. The locale will also be used as the default one for the \
installed system.")
#:info-textbox-width 70
#:listbox-items languages
#:listbox-item->text language->text
#:sort-listbox-items? #f
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-territory-page territories territory->text)
(let ((title (G_ "Locale location")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose your locale's location. This is a shortlist of \
locations based on the language you selected.")
#:listbox-items territories
#:listbox-item->text territory->text
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-codeset-page codesets)
(let ((title (G_ "Locale codeset")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose your locale's codeset. If UTF-8 is available, \
it should be preferred.")
#:listbox-items codesets
#:listbox-item->text identity
#:listbox-default-item "UTF-8"
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-modifier-page modifiers modifier->text)
(let ((title (G_ "Locale modifier")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose your locale's modifier. The most frequent \
modifier is euro. It indicates that you want to use Euro as the currency \
symbol.")
#:listbox-items modifiers
#:listbox-item->text modifier->text
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define* (run-locale-page #:key
supported-locales
iso639-languages
iso3166-territories)
"Run a page asking the user to select a locale language and possibly
territory, codeset and modifier. Use SUPPORTED-LOCALES as the list of glibc
available locales. ISO639-LANGUAGES is an association list associating a
locale code to a locale name. ISO3166-TERRITORIES is an association list
associating a territory code with a territory name. The formated locale, under
glibc format is returned."
(define (break-on-locale-found locales)
"Raise the &installer-step-break condition if LOCALES contains exactly one
element."
(and (= (length locales) 1)
(raise
(condition (&installer-step-break)))))
(define (filter-locales locales result)
"Filter the list of locale records LOCALES using the RESULT returned by
the installer-steps defined below."
(filter
(lambda (locale)
(and-map identity
`(,(string=? (locale-language locale)
(result-step result 'language))
,@(if (result-step-done? result 'territory)
(list (equal? (locale-territory locale)
(result-step result 'territory)))
'())
,@(if (result-step-done? result 'codeset)
(list (equal? (locale-codeset locale)
(result-step result 'codeset)))
'())
,@(if (result-step-done? result 'modifier)
(list (equal? (locale-modifier locale)
(result-step result 'modifier)))
'()))))
locales))
(define (result->locale-string locales result)
"Supposing that LOCALES contains exactly one locale record, turn it into a
glibc locale string and return it."
(match (filter-locales locales result)
((locale)
(locale->locale-string locale))))
(define (sort-languages languages)
"Extract some languages from LANGUAGES list and place them ahead."
(let* ((first-languages '("en"))
(other-languages (lset-difference equal?
languages
first-languages)))
`(,@first-languages ,@other-languages)))
(define locale-steps
(list
(installer-step
(id 'language)
(compute
(lambda _
(run-language-page
(sort-languages
(delete-duplicates (map locale-language supported-locales)))
(cut language-code->language-name iso639-languages <>)))))
(installer-step
(id 'territory)
(compute
(lambda (result _)
(let ((locales (filter-locales supported-locales result)))
;; Stop the process if the language returned by the previous step
;; is matching one and only one supported locale.
(break-on-locale-found locales)
;; Otherwise, ask the user to select a territory among those
;; supported by the previously selected language.
(run-territory-page
(delete-duplicates (map locale-territory locales))
(lambda (territory-code)
(if territory-code
(territory-code->territory-name iso3166-territories
territory-code)
(G_ "No location"))))))))
(installer-step
(id 'codeset)
(compute
(lambda (result _)
(let ((locales (filter-locales supported-locales result)))
;; Same as above but we now have a language and a territory to
;; narrow down the search of a locale.
(break-on-locale-found locales)
;; Otherwise, ask for a codeset.
(run-codeset-page
(delete-duplicates (map locale-codeset locales)))))))
(installer-step
(id 'modifier)
(compute
(lambda (result _)
(let ((locales (filter-locales supported-locales result)))
;; Same thing with a language, a territory and a codeset this time.
(break-on-locale-found locales)
;; Otherwise, ask for a modifier.
(run-modifier-page
(delete-duplicates (map locale-modifier locales))
(lambda (modifier)
(or modifier (G_ "No modifier"))))))))))
;; If run-installer-steps returns locally, it means that the user had to go
;; through all steps (language, territory, codeset and modifier) to select a
;; locale. In that case, like if we exited by raising &installer-step-break
;; condition, turn the result into a glibc locale string and return it.
(result->locale-string
supported-locales
(run-installer-steps #:steps locale-steps)))

44
gnu/installer/newt/menu.scm Normal file
View File

@ -0,0 +1,44 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt menu)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (newt)
#:export (run-menu-page))
(define (run-menu-page steps)
"Run a menu page, asking the user to select where to resume the install
process from."
(define (steps->items steps)
(filter (lambda (step)
(installer-step-description step))
steps))
(run-listbox-selection-page
#:info-text (G_ "Choose where you want to resume the install.\
You can also abort the installation by pressing the Abort button.")
#:title (G_ "Installation menu")
#:listbox-items (steps->items steps)
#:listbox-item->text installer-step-description
#:sort-listbox-items? #f
#:button-text (G_ "Abort")
#:button-callback-procedure (lambda ()
(newt-finish)
(primitive-exit 1))))

173
gnu/installer/newt/network.scm Normal file
View File

@ -0,0 +1,173 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt network)
#:use-module (gnu installer connman)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt ethernet)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt wifi)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-network-page))
;; Maximum length of a technology name.
(define technology-name-max-length (make-parameter 20))
(define (technology->text technology)
"Return a string describing the given TECHNOLOGY."
(let* ((name (technology-name technology))
(padded-name (string-pad-right name
(technology-name-max-length))))
(format #f "~a~%" padded-name)))
(define (run-technology-page)
"Run a page to ask the user which technology shall be used to access
Internet and return the selected technology. For now, only technologies with
\"ethernet\" or \"wifi\" types are supported."
(define (technology-items)
(filter (lambda (technology)
(let ((type (technology-type technology)))
(or
(string=? type "ethernet")
(string=? type "wifi"))))
(connman-technologies)))
(let ((items (technology-items)))
(if (null? items)
(case (choice-window
(G_ "Internet access")
(G_ "Continue")
(G_ "Exit")
(G_ "The install process requires an internet access, but no \
network device were found. Do you want to continue anyway?"))
((1) (raise
(condition
(&installer-step-break))))
((2) (raise
(condition
(&installer-step-abort)))))
(run-listbox-selection-page
#:info-text (G_ "The install process requires an internet access.\
Please select a network device.")
#:title (G_ "Internet access")
#:listbox-items items
#:listbox-item->text technology->text
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort))))))))
(define (find-technology-by-type technologies type)
"Find and return a technology with the given TYPE in TECHNOLOGIES list."
(find (lambda (technology)
(string=? (technology-type technology)
type))
technologies))
(define (wait-technology-powered technology)
"Wait and display a progress bar until the given TECHNOLOGY is powered."
(let ((name (technology-name technology))
(full-value 5))
(run-scale-page
#:title (G_ "Powering technology")
#:info-text (format #f "Waiting for technology ~a to be powered." name)
#:scale-full-value full-value
#:scale-update-proc
(lambda (value)
(let* ((technologies (connman-technologies))
(type (technology-type technology))
(updated-technology
(find-technology-by-type technologies type))
(technology-powered? updated-technology))
(sleep 1)
(if technology-powered?
full-value
(+ value 1)))))))
(define (wait-service-online)
"Display a newt scale until connman detects an Internet access. Do
FULL-VALUE tentatives, spaced by 1 second."
(let* ((full-value 5))
(run-scale-page
#:title (G_ "Checking connectivity")
#:info-text (G_ "Waiting internet access is established.")
#:scale-full-value full-value
#:scale-update-proc
(lambda (value)
(sleep 1)
(if (connman-online?)
full-value
(+ value 1))))
(unless (connman-online?)
(run-error-page
(G_ "The selected network does not provide an Internet \
access, please try again.")
(G_ "Connection error"))
(raise
(condition
(&installer-step-abort))))))
(define (run-network-page)
"Run a page to allow the user to configure connman so that it can access the
Internet."
(define network-steps
(list
;; Ask the user to choose between ethernet and wifi technologies.
(installer-step
(id 'select-technology)
(compute
(lambda _
(run-technology-page))))
;; Enable the previously selected technology.
(installer-step
(id 'power-technology)
(compute
(lambda (result _)
(let ((technology (result-step result 'select-technology)))
(connman-enable-technology technology)
(wait-technology-powered technology)))))
;; Propose the user to connect to one of the service available for the
;; previously selected technology.
(installer-step
(id 'connect-service)
(compute
(lambda (result _)
(let* ((technology (result-step result 'select-technology))
(type (technology-type technology)))
(cond
((string=? "wifi" type)
(run-wifi-page))
((string=? "ethernet" type)
(run-ethernet-page)))))))
;; Wait for connman status to switch to 'online, which means it can
;; access Internet.
(installer-step
(id 'wait-online)
(compute (lambda _
(wait-service-online))))))
(run-installer-steps
#:steps network-steps
#:rewind-strategy 'start))

530
gnu/installer/newt/page.scm Normal file
View File

@ -0,0 +1,530 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt page)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (newt)
#:export (draw-info-page
draw-connecting-page
run-input-page
run-error-page
run-listbox-selection-page
run-scale-page
run-checkbox-tree-page
run-file-textbox-page))
;;; Commentary:
;;;
;;; Some helpers around guile-newt to draw or run generic pages. The
;;; difference between 'draw' and 'run' terms comes from newt library. A page
;;; is drawn when the form it contains does not expect any user
;;; interaction. In that case, it is necessary to call (newt-refresh) to force
;;; the page to be displayed. When a form is 'run', it is blocked waiting for
;;; any action from the user (press a button, input some text, ...).
;;;
;;; Code:
(define (draw-info-page text title)
"Draw an informative page with the given TEXT as content. Set the title of
this page to TITLE."
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
(grid (make-grid 1 1))
(form (make-form)))
(set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
(add-component-to-form form text-box)
(make-wrapped-grid-window grid title)
(draw-form form)
;; This call is imperative, otherwise the form won't be displayed. See the
;; explanation in the above commentary.
(newt-refresh)
form))
(define (draw-connecting-page service-name)
"Draw a page to indicate a connection in in progress."
(draw-info-page
(format #f (G_ "Connecting to ~a, please wait.") service-name)
(G_ "Connection in progress")))
(define* (run-input-page text title
#:key
(allow-empty-input? #f)
(default-text #f)
(input-field-width 40))
"Run a page to prompt user for an input. The given TEXT will be displayed
above the input field. The page title is set to TITLE. Unless
allow-empty-input? is set to #t, an error page will be displayed if the user
enters an empty input."
(let* ((text-box
(make-reflowed-textbox -1 -1 text
input-field-width
#:flags FLAG-BORDER))
(grid (make-grid 1 3))
(input-entry (make-entry -1 -1 20))
(ok-button (make-button -1 -1 (G_ "OK")))
(form (make-form)))
(when default-text
(set-entry-text input-entry default-text))
(set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
(set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
#:pad-top 1)
(set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button
#:pad-top 1)
(add-components-to-form form text-box input-entry ok-button)
(make-wrapped-grid-window grid title)
(let ((error-page (lambda ()
(run-error-page (G_ "Please enter a non empty input.")
(G_ "Empty input")))))
(let loop ()
(receive (exit-reason argument)
(run-form form)
(let ((input (entry-value input-entry)))
(if (and (not allow-empty-input?)
(eq? exit-reason 'exit-component)
(string=? input ""))
(begin
;; Display the error page.
(error-page)
;; Set the focus back to the input input field.
(set-current-component form input-entry)
(loop))
(begin
(destroy-form-and-pop form)
input))))))))
(define (run-error-page text title)
"Run a page to inform the user of an error. The page contains the given TEXT
to explain the error and an \"OK\" button to acknowledge the error. The title
of the page is set to TITLE."
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
(grid (make-grid 1 2))
(ok-button (make-button -1 -1 "OK"))
(form (make-form)))
(set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
(set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button
#:pad-top 1)
;; Set the background color to red to indicate something went wrong.
(newt-set-color COLORSET-ROOT "white" "red")
(add-components-to-form form text-box ok-button)
(make-wrapped-grid-window grid title)
(run-form form)
;; Restore the background to its original color.
(newt-set-color COLORSET-ROOT "white" "blue")
(destroy-form-and-pop form)))
(define* (run-listbox-selection-page #:key
info-text
title
(info-textbox-width 50)
listbox-items
listbox-item->text
(listbox-height 20)
(listbox-default-item #f)
(listbox-allow-multiple? #f)
(sort-listbox-items? #t)
(allow-delete? #f)
(skip-item-procedure?
(const #f))
button-text
(button-callback-procedure
(const #t))
(button2-text #f)
(button2-callback-procedure
(const #t))
(listbox-callback-procedure
identity)
(hotkey-callback-procedure
(const #t)))
"Run a page asking the user to select an item in a listbox. The page
contains, stacked vertically from the top to the bottom, an informative text
set to INFO-TEXT, a listbox and a button. The listbox will be filled with
LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
on every item. The selected item from LISTBOX-ITEMS is returned. The button
text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
item from the listbox is selected (by pressing the <ENTER> key).
INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
displayed. LISTBOX-HEIGHT is the height of the listbox.
If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
the listbox is selected.
If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
be selected (using the <SPACE> key). It that case, a list containing the
selected items will be returned.
If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
'string<=' procedure (after being converted to text).
If ALLOW-DELETE? is #t, the form will return if the <DELETE> key is pressed,
otherwise nothing will happend.
Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the
current listbox item as argument. If it returns #t, skip the element and jump
to the next/previous one depending on the previous item, otherwise do
nothing."
(define (fill-listbox listbox items)
"Append the given ITEMS to LISTBOX, once they have been converted to text
with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
newt. Save this key by returning an association list under the form:
((NEWT-LISTBOX-KEY . ITEM) ...)
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
ITEM was inserted into LISTBOX."
(map (lambda (item)
(let* ((text (listbox-item->text item))
(key (append-entry-to-listbox listbox text)))
(cons key item)))
items))
(define (sort-listbox-items listbox-items)
"Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text
corresponding to each item in the list."
(let* ((items (map (lambda (item)
(cons item (listbox-item->text item)))
listbox-items))
(sorted-items
(sort items (lambda (a b)
(let ((text-a (cdr a))
(text-b (cdr b)))
(string<= text-a text-b))))))
(map car sorted-items)))
;; Store the last selected listbox item's key.
(define last-listbox-key (make-parameter #f))
(define (previous-key keys key)
(let ((index (list-index (cut eq? key <>) keys)))
(and index
(> index 0)
(list-ref keys (- index 1)))))
(define (next-key keys key)
(let ((index (list-index (cut eq? key <>) keys)))
(and index
(< index (- (length keys) 1))
(list-ref keys (+ index 1)))))
(define (set-default-item listbox listbox-keys default-item)
"Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
association list returned by the FILL-LISTBOX procedure. It is used because
the current listbox item has to be selected by key."
(for-each (match-lambda
((key . item)
(when (equal? item default-item)
(set-current-listbox-entry-by-key listbox key))))
listbox-keys))
(let* ((listbox (make-listbox
-1 -1
listbox-height
(logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
(if listbox-allow-multiple?
FLAG-MULTIPLE
0))))
(form (make-form))
(info-textbox
(make-reflowed-textbox -1 -1 info-text
info-textbox-width
#:flags FLAG-BORDER))
(button (make-button -1 -1 button-text))
(button2 (and button2-text
(make-button -1 -1 button2-text)))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT listbox
GRID-ELEMENT-SUBGRID
(apply
horizontal-stacked-grid
GRID-ELEMENT-COMPONENT button
`(,@(if button2
(list GRID-ELEMENT-COMPONENT button2)
'())))))
(sorted-items (if sort-listbox-items?
(sort-listbox-items listbox-items)
listbox-items))
(keys (fill-listbox listbox sorted-items)))
;; On every listbox element change, check if we need to skip it. If yes,
;; depending on the 'last-listbox-key', jump forward or backward. If no,
;; do nothing.
(add-component-callback
listbox
(lambda (component)
(let* ((current-key (current-listbox-entry listbox))
(listbox-keys (map car keys))
(last-key (last-listbox-key))
(item (assoc-ref keys current-key))
(prev-key (previous-key listbox-keys current-key))
(next-key (next-key listbox-keys current-key)))
;; Update last-listbox-key before a potential call to
;; set-current-listbox-entry-by-key, because it will immediately
;; cause this callback to be called for the new entry.
(last-listbox-key current-key)
(when (skip-item-procedure? item)
(when (eq? prev-key last-key)
(if next-key
(set-current-listbox-entry-by-key listbox next-key)
(set-current-listbox-entry-by-key listbox prev-key)))
(when (eq? next-key last-key)
(if prev-key
(set-current-listbox-entry-by-key listbox prev-key)
(set-current-listbox-entry-by-key listbox next-key)))))))
(when listbox-default-item
(set-default-item listbox keys listbox-default-item))
(when allow-delete?
(form-add-hotkey form KEY-DELETE))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(case exit-reason
((exit-component)
(cond
((components=? argument button)
(button-callback-procedure))
((and button2
(components=? argument button2))
(button2-callback-procedure))
((components=? argument listbox)
(if listbox-allow-multiple?
(let* ((entries (listbox-selection listbox))
(items (map (lambda (entry)
(assoc-ref keys entry))
entries)))
(listbox-callback-procedure items))
(let* ((entry (current-listbox-entry listbox))
(item (assoc-ref keys entry)))
(listbox-callback-procedure item))))))
((exit-hotkey)
(let* ((entry (current-listbox-entry listbox))
(item (assoc-ref keys entry)))
(hotkey-callback-procedure argument item)))))
(lambda ()
(destroy-form-and-pop form))))))
(define* (run-scale-page #:key
title
info-text
(info-textbox-width 50)
(scale-width 40)
(scale-full-value 100)
scale-update-proc
(max-scale-update 5))
"Run a page with a progress bar (called 'scale' in newt). The given
INFO-TEXT is displayed in a textbox above the scale. The width of the textbox
is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to
SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of
the scale.
The procedure SCALE-UPDATE-PROC shall return a new scale
value. SCALE-UPDATE-PROC will be called until the returned value is superior
or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An
error is raised if the MAX-SCALE-UPDATE limit is reached."
(let* ((info-textbox
(make-reflowed-textbox -1 -1 info-text
info-textbox-width
#:flags FLAG-BORDER))
(scale (make-scale -1 -1 scale-width scale-full-value))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT scale))
(form (make-form)))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(draw-form form)
;; This call is imperative, otherwise the form won't be displayed. See the
;; explanation in the above commentary.
(newt-refresh)
(dynamic-wind
(const #t)
(lambda ()
(let loop ((i max-scale-update)
(last-value 0))
(let ((value (scale-update-proc last-value)))
(set-scale-value scale value)
;; Same as above.
(newt-refresh)
(unless (>= value scale-full-value)
(if (> i 0)
(loop (- i 1) value)
(error "Max scale updates reached."))))))
(lambda ()
(destroy-form-and-pop form)))))
(define* (run-checkbox-tree-page #:key
info-text
title
items
item->text
(info-textbox-width 50)
(checkbox-tree-height 10)
(ok-button-callback-procedure
(const #t))
(exit-button-callback-procedure
(const #t)))
"Run a page allowing the user to select one or multiple items among ITEMS in
a checkbox list. The page contains vertically stacked from the top to the
bottom, an informative text set to INFO-TEXT, the checkbox list and two
buttons, 'Ok' and 'Exit'. The page title's is set to TITLE. ITEMS are
converted to text using ITEM->TEXT before being displayed in the checkbox
list.
INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list.
OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed.
EXIT-BUTTON-CALLBACK-PROCEDURE is called when the 'Exit' button is
pressed.
This procedure returns the list of checked items in the checkbox list among
ITEMS when 'Ok' is pressed."
(define (fill-checkbox-tree checkbox-tree items)
(map
(lambda (item)
(let* ((item-text (item->text item))
(key (add-entry-to-checkboxtree checkbox-tree item-text 0)))
(cons key item)))
items))
(let* ((checkbox-tree
(make-checkboxtree -1 -1
checkbox-tree-height
FLAG-BORDER))
(info-textbox
(make-reflowed-textbox -1 -1 info-text
info-textbox-width
#:flags FLAG-BORDER))
(ok-button (make-button -1 -1 (G_ "OK")))
(exit-button (make-button -1 -1 (G_ "Exit")))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT checkbox-tree
GRID-ELEMENT-SUBGRID
(horizontal-stacked-grid
GRID-ELEMENT-COMPONENT ok-button
GRID-ELEMENT-COMPONENT exit-button)))
(keys (fill-checkbox-tree checkbox-tree items))
(form (make-form)))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(case exit-reason
((exit-component)
(cond
((components=? argument ok-button)
(let* ((entries (current-checkbox-selection checkbox-tree))
(current-items (map (lambda (entry)
(assoc-ref keys entry))
entries)))
(ok-button-callback-procedure)
current-items))
((components=? argument exit-button)
(exit-button-callback-procedure))))))
(lambda ()
(destroy-form-and-pop form))))))
(define* (run-file-textbox-page #:key
info-text
title
file
(info-textbox-width 50)
(file-textbox-width 50)
(file-textbox-height 30)
(exit-button? #t)
(ok-button-callback-procedure
(const #t))
(exit-button-callback-procedure
(const #t)))
(let* ((info-textbox
(make-reflowed-textbox -1 -1 info-text
info-textbox-width
#:flags FLAG-BORDER))
(file-text (read-all file))
(file-textbox
(make-textbox -1 -1
file-textbox-width
file-textbox-height
(logior FLAG-SCROLL FLAG-BORDER)))
(ok-button (make-button -1 -1 (G_ "OK")))
(exit-button (make-button -1 -1 (G_ "Exit")))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT file-textbox
GRID-ELEMENT-SUBGRID
(apply
horizontal-stacked-grid
GRID-ELEMENT-COMPONENT ok-button
`(,@(if exit-button?
(list GRID-ELEMENT-COMPONENT exit-button)
'())))))
(form (make-form)))
(set-textbox-text file-textbox file-text)
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(case exit-reason
((exit-component)
(cond
((components=? argument ok-button)
(ok-button-callback-procedure))
((and exit-button?
(components=? argument exit-button))
(exit-button-callback-procedure))))))
(lambda ()
(destroy-form-and-pop form))))))

766
gnu/installer/newt/partition.scm Normal file
View File

@ -0,0 +1,766 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt partition)
#:use-module (gnu installer parted)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:use-module (parted)
#:export (run-partioning-page))
(define (button-exit-action)
"Raise the &installer-step-abort condition."
(raise
(condition
(&installer-step-abort))))
(define (run-scheme-page)
"Run a page asking the user for a partitioning scheme."
(let* ((items
'((root . "Everything is one partition")
(root-home . "Separate /home partition")))
(result (run-listbox-selection-page
#:info-text (G_ "Please select a partitioning scheme.")
#:title (G_ "Partition scheme")
#:listbox-items items
#:listbox-item->text cdr
#:button-text (G_ "Exit")
#:button-callback-procedure button-exit-action)))
(car result)))
(define (draw-formatting-page)
"Draw a page to indicate partitions are being formated."
(draw-info-page
(format #f (G_ "Partition formatting is in progress, please wait."))
(G_ "Preparing partitions")))
(define (run-device-page devices)
"Run a page asking the user to select a device among those in the given
DEVICES list."
(define (device-items)
(map (lambda (device)
`(,device . ,(device-description device)))
devices))
(let* ((result (run-listbox-selection-page
#:info-text (G_ "Please select a disk.")
#:title (G_ "Disk")
#:listbox-items (device-items)
#:listbox-item->text cdr
#:button-text (G_ "Exit")
#:button-callback-procedure button-exit-action))
(device (car result)))
device))
(define (run-label-page button-text button-callback)
"Run a page asking the user to select a partition table label."
(run-listbox-selection-page
#:info-text (G_ "Select a new partition table type. \
Be careful, all data on the disk will be lost.")
#:title (G_ "Partition table")
#:listbox-items '("msdos" "gpt")
#:listbox-item->text identity
#:button-text button-text
#:button-callback-procedure button-callback))
(define (run-type-page partition)
"Run a page asking the user to select a partition type."
(let* ((disk (partition-disk partition))
(partitions (disk-partitions disk))
(other-extended-partitions?
(any extended-partition? partitions))
(items
`(normal ,@(if other-extended-partitions?
'()
'(extended)))))
(run-listbox-selection-page
#:info-text (G_ "Please select a partition type.")
#:title (G_ "Partition type")
#:listbox-items items
#:listbox-item->text symbol->string
#:sort-listbox-items? #f
#:button-text (G_ "Exit")
#:button-callback-procedure button-exit-action)))
(define (run-fs-type-page)
"Run a page asking the user to select a file-system type."
(run-listbox-selection-page
#:info-text (G_ "Please select the file-system type for this partition.")
#:title (G_ "File-system type")
#:listbox-items '(ext4 btrfs fat32 swap)
#:listbox-item->text user-fs-type-name
#:sort-listbox-items? #f
#:button-text (G_ "Exit")
#:button-callback-procedure button-exit-action))
(define (inform-can-create-partition? user-partition)
"Return #t if it is possible to create USER-PARTITION. This is determined by
calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it
an inform the user with an appropriate error-page and return #f."
(guard (c ((max-primary-exceeded? c)
(run-error-page
(G_ "Primary partitions count exceeded.")
(G_ "Creation error"))
#f)
((extended-creation-error? c)
(run-error-page
(G_ "Extended partition creation error.")
(G_ "Creation error"))
#f)
((logical-creation-error? c)
(run-error-page
(G_ "Logical partition creation error.")
(G_ "Creation error"))
#f))
(can-create-partition? user-partition)))
(define (prompt-luks-passwords user-partitions)
"Prompt for the luks passwords of the encrypted partitions in
USER-PARTITIONS list. Return this list with password fields filled-in."
(map (lambda (user-part)
(let* ((crypt-label (user-partition-crypt-label user-part))
(file-name (user-partition-file-name user-part))
(password-page
(lambda ()
(run-input-page
(format #f (G_ "Please enter the password for the \
encryption of partition ~a (label: ~a).") file-name crypt-label)
(G_ "Password required"))))
(password-confirm-page
(lambda ()
(run-input-page
(format #f (G_ "Please confirm the password for the \
encryption of partition ~a (label: ~a).") file-name crypt-label)
(G_ "Password confirmation required")))))
(if crypt-label
(let loop ()
(let ((password (password-page))
(confirmation (password-confirm-page)))
(if (string=? password confirmation)
(user-partition
(inherit user-part)
(crypt-password password))
(begin
(run-error-page
(G_ "Password mismatch, please try again.")
(G_ "Password error"))
(loop)))))
user-part)))
user-partitions))
(define* (run-partition-page target-user-partition
#:key
(default-item #f))
"Run a page allowing the user to edit the given TARGET-USER-PARTITION
record. If the argument DEFAULT-ITEM is passed, use it to select the current
listbox item. This is used to avoid the focus to switch back to the first
listbox entry while calling this procedure recursively."
(define (numeric-size device size)
"Parse the given SIZE on DEVICE and return it."
(call-with-values
(lambda ()
(unit-parse size device))
(lambda (value range)
value)))
(define (numeric-size-range device size)
"Parse the given SIZE on DEVICE and return the associated RANGE."
(call-with-values
(lambda ()
(unit-parse size device))
(lambda (value range)
range)))
(define* (fill-user-partition-geom user-part
#:key
device (size #f) start end)
"Return the given USER-PART with the START, END and SIZE fields set to the
eponym arguments. Use UNIT-FORMAT-CUSTOM to format START and END arguments as
sectors on DEVICE."
(user-partition
(inherit user-part)
(size size)
(start (unit-format-custom device start UNIT-SECTOR))
(end (unit-format-custom device end UNIT-SECTOR))))
(define (apply-user-partition-changes user-part)
"Set the name, file-system type and boot flag on the partition specified
by USER-PART, if it is applicable for the partition type."
(let* ((partition (user-partition-parted-object user-part))
(disk (partition-disk partition))
(disk-type (disk-disk-type disk))
(device (disk-device disk))
(has-name? (disk-type-check-feature
disk-type
DISK-TYPE-FEATURE-PARTITION-NAME))
(name (user-partition-name user-part))
(fs-type (filesystem-type-get
(user-fs-type-name
(user-partition-fs-type user-part))))
(bootable? (user-partition-bootable? user-part))
(esp? (user-partition-esp? user-part))
(flag-bootable?
(partition-is-flag-available? partition PARTITION-FLAG-BOOT))
(flag-esp?
(partition-is-flag-available? partition PARTITION-FLAG-ESP)))
(when (and has-name? name)
(partition-set-name partition name))
(partition-set-system partition fs-type)
(when flag-bootable?
(partition-set-flag partition
PARTITION-FLAG-BOOT
(if bootable? 1 0)))
(when flag-esp?
(partition-set-flag partition
PARTITION-FLAG-ESP
(if esp? 1 0)))
#t))
(define (listbox-action listbox-item)
(let* ((item (car listbox-item))
(partition (user-partition-parted-object
target-user-partition))
(disk (partition-disk partition))
(device (disk-device disk)))
(list
item
(case item
((name)
(let* ((old-name (user-partition-name target-user-partition))
(name
(run-input-page (G_ "Please enter the partition gpt name.")
(G_ "Partition name")
#:default-text old-name)))
(user-partition
(inherit target-user-partition)
(name name))))
((type)
(let ((new-type (run-type-page partition)))
(user-partition
(inherit target-user-partition)
(type new-type))))
((bootable)
(user-partition
(inherit target-user-partition)
(bootable? (not (user-partition-bootable?
target-user-partition)))))
((esp?)
(let ((new-esp? (not (user-partition-esp?
target-user-partition))))
(user-partition
(inherit target-user-partition)
(esp? new-esp?)
(mount-point (if new-esp?
(default-esp-mount-point)
"")))))
((crypt-label)
(let* ((label (user-partition-crypt-label
target-user-partition))
(new-label
(and (not label)
(run-input-page
(G_ "Please enter the encrypted label")
(G_ "Encryption label")))))
(user-partition
(inherit target-user-partition)
(need-formatting? #t)
(crypt-label new-label))))
((need-formatting?)
(user-partition
(inherit target-user-partition)
(need-formatting?
(not (user-partition-need-formatting?
target-user-partition)))))
((size)
(let* ((old-size (user-partition-size target-user-partition))
(max-size-value (partition-length partition))
(max-size (unit-format device max-size-value))
(start (partition-start partition))
(size (run-input-page
(format #f (G_ "Please enter the size of the partition.\
The maximum size is ~a.") max-size)
(G_ "Partition size")
#:default-text (or old-size max-size)))
(size-percentage (read-percentage size))
(size-value (if size-percentage
(nearest-exact-integer
(/ (* max-size-value size-percentage)
100))
(numeric-size device size)))
(end (and size-value
(+ start size-value)))
(size-range (numeric-size-range device size))
(size-range-ok? (and size-range
(< (+ start
(geometry-start size-range))
(partition-end partition)))))
(cond
((and size-percentage (> size-percentage 100))
(run-error-page
(G_ "The percentage can not be superior to 100.")
(G_ "Size error"))
target-user-partition)
((not size-value)
(run-error-page
(G_ "The requested size is incorrectly formatted, or too large.")
(G_ "Size error"))
target-user-partition)
((not (or size-percentage size-range-ok?))
(run-error-page
(G_ "The request size is superior to the maximum size.")
(G_ "Size error"))
target-user-partition)
(else
(fill-user-partition-geom target-user-partition
#:device device
#:size size
#:start start
#:end end)))))
((fs-type)
(let ((fs-type (run-fs-type-page)))
(user-partition
(inherit target-user-partition)
(fs-type fs-type))))
((mount-point)
(let* ((old-mount (or (user-partition-mount-point
target-user-partition)
""))
(mount
(run-input-page
(G_ "Please enter the desired mounting point for this \
partition. Leave this field empty if you don't want to set a mounting point.")
(G_ "Mounting point")
#:default-text old-mount
#:allow-empty-input? #t)))
(user-partition
(inherit target-user-partition)
(mount-point (and (not (string=? mount ""))
mount)))))))))
(define (button-action)
(let* ((partition (user-partition-parted-object
target-user-partition))
(prev-part (partition-prev partition))
(disk (partition-disk partition))
(device (disk-device disk))
(creation? (freespace-partition? partition))
(start (partition-start partition))
(end (partition-end partition))
(new-user-partition
(if (user-partition-start target-user-partition)
target-user-partition
(fill-user-partition-geom target-user-partition
#:device device
#:start start
#:end end))))
;; It the backend PARTITION has free-space type, it means we are
;; creating a new partition, otherwise, we are editing an already
;; existing PARTITION.
(if creation?
(let* ((ok-create-partition?
(inform-can-create-partition? new-user-partition))
(new-partition
(and ok-create-partition?
(mkpart disk
new-user-partition
#:previous-partition prev-part))))
(and new-partition
(user-partition
(inherit new-user-partition)
(need-formatting? #t)
(file-name (partition-get-path new-partition))
(disk-file-name (device-path device))
(parted-object new-partition))))
(and (apply-user-partition-changes new-user-partition)
new-user-partition))))
(let* ((items (user-partition-description target-user-partition))
(partition (user-partition-parted-object
target-user-partition))
(disk (partition-disk partition))
(device (disk-device disk))
(file-name (device-path device))
(number-str (partition-print-number partition))
(type (user-partition-type target-user-partition))
(type-str (symbol->string type))
(start (unit-format device (partition-start partition)))
(creation? (freespace-partition? partition))
(default-item (and default-item
(find (lambda (item)
(eq? (car item) default-item))
items)))
(result
(run-listbox-selection-page
#:info-text
(if creation?
(G_ (format #f "Creating ~a partition starting at ~a of ~a."
type-str start file-name))
(G_ (format #f "You are currently editing partition ~a."
number-str)))
#:title (if creation?
(G_ "Partition creation")
(G_ "Partition edit"))
#:listbox-items items
#:listbox-item->text cdr
#:sort-listbox-items? #f
#:listbox-default-item default-item
#:button-text (G_ "OK")
#:listbox-callback-procedure listbox-action
#:button-callback-procedure button-action)))
(match result
((item new-user-partition)
(run-partition-page new-user-partition
#:default-item item))
(else result))))
(define* (run-disk-page disks
#:optional (user-partitions '())
#:key (guided? #f))
"Run a page allowing to edit the partition tables of the given DISKS. If
specified, USER-PARTITIONS is a list of <user-partition> records associated to
the partitions on DISKS."
(define (other-logical-partitions? partitions)
"Return #t if at least one of the partition in PARTITIONS list is a
logical partition, return #f otherwise."
(any logical-partition? partitions))
(define (other-non-logical-partitions? partitions)
"Return #t is at least one of the partitions in PARTITIONS list is not a
logical partition, return #f otherwise."
(let ((non-logical-partitions
(remove logical-partition? partitions)))
(or (any normal-partition? non-logical-partitions)
(any freespace-partition? non-logical-partitions))))
(define (add-tree-symbols partitions descriptions)
"Concatenate tree symbols to the given DESCRIPTIONS list and return
it. The PARTITIONS list is the list of partitions described in
DESCRIPTIONS. The tree symbols are used to indicate the partition's disk and
for logical partitions, the extended partition which includes them."
(match descriptions
(() '())
((description . rest-descriptions)
(match partitions
((partition . rest-partitions)
(if (null? rest-descriptions)
(list (if (logical-partition? partition)
(string-append " ┗━ " description)
(string-append "┗━ " description)))
(cons (cond
((extended-partition? partition)
(if (other-non-logical-partitions? rest-partitions)
(string-append "┣┳ " description)
(string-append "┗┳ " description)))
((logical-partition? partition)
(if (other-logical-partitions? rest-partitions)
(if (other-non-logical-partitions? rest-partitions)
(string-append "┃┣━ " description)
(string-append " ┣━ " description))
(if (other-non-logical-partitions? rest-partitions)
(string-append "┃┗━ " description)
(string-append " ┗━ " description))))
(else
(string-append "┣━ " description)))
(add-tree-symbols rest-partitions
rest-descriptions))))))))
(define (skip-item? item)
(eq? (car item) 'skip))
(define (disk-items)
"Return the list of strings describing DISKS."
(let loop ((disks disks))
(match disks
(() '())
((disk . rest)
(let* ((device (disk-device disk))
(partitions (disk-partitions disk))
(partitions*
(filter-map
(lambda (partition)
(and (not (metadata-partition? partition))
(not (small-freespace-partition? device
partition))
partition))
partitions))
(descriptions (add-tree-symbols
partitions*
(partitions-descriptions partitions*
user-partitions)))
(partition-items (map cons partitions* descriptions)))
(append
`((,disk . ,(device-description device disk))
,@partition-items
,@(if (null? rest)
'()
'((skip . ""))))
(loop rest)))))))
(define (remove-user-partition-by-partition user-partitions partition)
"Return the USER-PARTITIONS list with the record with the given PARTITION
object removed. If PARTITION is an extended partition, also remove all logical
partitions from USER-PARTITIONS."
(remove (lambda (p)
(let ((cur-partition (user-partition-parted-object p)))
(or (equal? cur-partition partition)
(and (extended-partition? partition)
(logical-partition? cur-partition)))))
user-partitions))
(define (remove-user-partition-by-disk user-partitions disk)
"Return the USER-PARTITIONS list with the <user-partition> records located
on given DISK removed."
(remove (lambda (p)
(let* ((partition (user-partition-parted-object p))
(cur-disk (partition-disk partition)))
(equal? cur-disk disk)))
user-partitions))
(define (update-user-partitions user-partitions new-user-partition)
"Update or insert NEW-USER-PARTITION record in USER-PARTITIONS list
depending if one of the <user-partition> record in USER-PARTITIONS has the
same PARTITION object as NEW-USER-PARTITION."
(let* ((partition (user-partition-parted-object new-user-partition))
(user-partitions*
(remove-user-partition-by-partition user-partitions
partition)))
(cons new-user-partition user-partitions*)))
(define (button-ok-action)
"Commit the modifications to all DISKS and return #t."
(for-each (lambda (disk)
(disk-commit disk))
disks)
#t)
(define (listbox-action listbox-item)
"A disk or a partition has been selected. If it's a disk, ask for a label
to create a new partition table. If it is a partition, propose the user to
edit it."
(let ((item (car listbox-item)))
(cond
((disk? item)
(let ((label (run-label-page (G_ "Back") (const #f))))
(if label
(let* ((device (disk-device item))
(new-disk (mklabel device label))
(commit-new-disk (disk-commit new-disk))
(other-disks (remove (lambda (disk)
(equal? disk item))
disks))
(new-user-partitions
(remove-user-partition-by-disk user-partitions item)))
(disk-destroy item)
`((disks . ,(cons new-disk other-disks))
(user-partitions . ,new-user-partitions)))
`((disks . ,disks)
(user-partitions . ,user-partitions)))))
((partition? item)
(let* ((partition item)
(disk (partition-disk partition))
(device (disk-device disk))
(existing-user-partition
(find-user-partition-by-parted-object user-partitions
partition))
(edit-user-partition
(or existing-user-partition
(partition->user-partition partition))))
`((disks . ,disks)
(user-partitions . ,user-partitions)
(edit-user-partition . ,edit-user-partition)))))))
(define (hotkey-action key listbox-item)
"The DELETE key has been pressed on a disk or a partition item."
(let ((item (car listbox-item))
(default-result
`((disks . ,disks)
(user-partitions . ,user-partitions))))
(cond
((disk? item)
(let* ((device (disk-device item))
(file-name (device-path device))
(info-text
(format #f (G_ "Are you sure you want to delete everything on disk ~a?")
file-name))
(result (choice-window (G_ "Delete disk")
(G_ "OK")
(G_ "Exit")
info-text)))
(case result
((1)
(disk-delete-all item)
`((disks . ,disks)
(user-partitions
. ,(remove-user-partition-by-disk user-partitions item))))
(else
default-result))))
((partition? item)
(if (freespace-partition? item)
(run-error-page (G_ "You cannot delete a free space area.")
(G_ "Delete partition"))
(let* ((disk (partition-disk item))
(number-str (partition-print-number item))
(info-text
(format #f (G_ "Are you sure you want to delete partition ~a?")
number-str))
(result (choice-window (G_ "Delete partition")
(G_ "OK")
(G_ "Exit")
info-text)))
(case result
((1)
(let ((new-user-partitions
(remove-user-partition-by-partition user-partitions
item)))
(disk-delete-partition disk item)
`((disks . ,disks)
(user-partitions . ,new-user-partitions))))
(else
default-result))))))))
(let* ((info-text (G_ "You can change a disk's partition table by \
selecting it and pressing ENTER. You can also edit a partition by selecting it \
and pressing ENTER, or remove it by pressing DELETE. To create a new \
partition, select a free space area and press ENTER.
At least one partition must have its mounting point set to '/'."))
(guided-info-text (format #f (G_ "This is the proposed \
partitioning. It is still possible to edit it or to go back to install menu \
by pressing the Exit button.~%~%")))
(result
(run-listbox-selection-page
#:info-text (if guided?
(string-append guided-info-text info-text)
info-text)
#:title (if guided?
(G_ "Guided partitioning")
(G_ "Manual partitioning"))
#:info-textbox-width 70
#:listbox-items (disk-items)
#:listbox-item->text cdr
#:sort-listbox-items? #f
#:skip-item-procedure? skip-item?
#:allow-delete? #t
#:button-text (G_ "OK")
#:button-callback-procedure button-ok-action
#:button2-text (G_ "Exit")
#:button2-callback-procedure button-exit-action
#:listbox-callback-procedure listbox-action
#:hotkey-callback-procedure hotkey-action)))
(if (eq? result #t)
(let ((user-partitions-ok?
(guard
(c ((no-root-mount-point? c)
(run-error-page
(G_ "No root mount point found.")
(G_ "Missing mount point"))
#f))
(check-user-partitions user-partitions))))
(if user-partitions-ok?
(begin
(for-each (cut disk-destroy <>) disks)
user-partitions)
(run-disk-page disks user-partitions
#:guided? guided?)))
(let* ((result-disks (assoc-ref result 'disks))
(result-user-partitions (assoc-ref result
'user-partitions))
(edit-user-partition (assoc-ref result
'edit-user-partition))
(can-create-partition?
(and edit-user-partition
(inform-can-create-partition? edit-user-partition)))
(new-user-partition (and edit-user-partition
can-create-partition?
(run-partition-page
edit-user-partition)))
(new-user-partitions
(if new-user-partition
(update-user-partitions result-user-partitions
new-user-partition)
result-user-partitions)))
(run-disk-page result-disks new-user-partitions
#:guided? guided?)))))
(define (run-partioning-page)
"Run a page asking the user for a partitioning method."
(define (run-page devices)
(let* ((items
'((entire . "Guided - using the entire disk")
(entire-encrypted . "Guided - using the entire disk with encryption")
(manual . "Manual")))
(result (run-listbox-selection-page
#:info-text (G_ "Please select a partitioning method.")
#:title (G_ "Partitioning method")
#:listbox-items items
#:listbox-item->text cdr
#:button-text (G_ "Exit")
#:button-callback-procedure button-exit-action))
(method (car result)))
(cond
((or (eq? method 'entire)
(eq? method 'entire-encrypted))
(let* ((device (run-device-page devices))
(disk-type (disk-probe device))
(disk (if disk-type
(disk-new device)
(let* ((label (run-label-page
(G_ "Exit")
button-exit-action))
(disk (mklabel device label)))
(disk-commit disk)
disk)))
(scheme (symbol-append method '- (run-scheme-page)))
(user-partitions (append
(auto-partition disk #:scheme scheme)
(create-special-user-partitions
(disk-partitions disk)))))
(run-disk-page (list disk) user-partitions
#:guided? #t)))
((eq? method 'manual)
(let* ((disks (filter-map disk-new devices))
(user-partitions (append-map
create-special-user-partitions
(map disk-partitions disks)))
(result-user-partitions (run-disk-page disks
user-partitions)))
result-user-partitions)))))
(init-parted)
(let* ((non-install-devices (non-install-devices))
(user-partitions (run-page non-install-devices))
(user-partitions-with-pass (prompt-luks-passwords
user-partitions))
(form (draw-formatting-page)))
;; Make sure the disks are not in use before proceeding to formatting.
(free-parted non-install-devices)
(format-user-partitions user-partitions-with-pass)
(destroy-form-and-pop form)
user-partitions))

48
gnu/installer/newt/services.scm Normal file
View File

@ -0,0 +1,48 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt services)
#:use-module (gnu installer services)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-services-page))
(define (run-desktop-environments-cbt-page)
"Run a page allowing the user to choose between various desktop
environments."
(run-checkbox-tree-page
#:info-text (G_ "Please select the desktop(s) environment(s) you wish to \
install. If you select multiple desktops environments, we will be able to \
choose the one to use on the log-in screen with F1.")
#:title (G_ "Desktop environment")
#:items %desktop-environments
#:item->text desktop-environment-name
#:checkbox-tree-height 5
#:exit-button-callback-procedure
(lambda ()
(raise
(condition
(&installer-step-abort))))))
(define (run-services-page)
(run-desktop-environments-cbt-page))

83
gnu/installer/newt/timezone.scm Normal file
View File

@ -0,0 +1,83 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt timezone)
#:use-module (gnu installer steps)
#:use-module (gnu installer timezone)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (run-timezone-page))
;; Heigth of the listbox displaying timezones.
(define timezone-listbox-heigth (make-parameter 20))
;; Information textbox width.
(define info-textbox-width (make-parameter 40))
(define (fill-timezones listbox timezones)
"Fill the given LISTBOX with TIMEZONES. Return an association list
correlating listbox keys with timezones."
(map (lambda (timezone)
(let ((key (append-entry-to-listbox listbox timezone)))
(cons key timezone)))
timezones))
(define (run-timezone-page zonetab)
"Run a page displaying available timezones, grouped by regions. The user is
invited to select a timezone. The selected timezone, under Posix format is
returned."
(define (all-but-last list)
(reverse (cdr (reverse list))))
(define (run-page timezone-tree)
(define (loop path)
(let ((timezones (locate-childrens timezone-tree path)))
(run-listbox-selection-page
#:title (G_ "Timezone")
#:info-text (G_ "Please select a timezone.")
#:listbox-items timezones
#:listbox-item->text identity
#:button-text (if (null? path)
(G_ "Exit")
(G_ "Back"))
#:button-callback-procedure
(if (null? path)
(lambda _
(raise
(condition
(&installer-step-abort))))
(lambda _
(loop (all-but-last path))))
#:listbox-callback-procedure
(lambda (timezone)
(let* ((timezone* (append path (list timezone)))
(tz (timezone->posix-tz timezone*)))
(if (timezone-has-child? timezone-tree timezone*)
(loop timezone*)
tz))))))
(loop '()))
(let ((timezone-tree (zonetab->timezone-tree zonetab)))
(run-page timezone-tree)))

175
gnu/installer/newt/user.scm Normal file
View File

@ -0,0 +1,175 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt user)
#:use-module (gnu installer user)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (newt)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (run-user-page))
(define (run-user-add-page)
(define (pad-label label)
(string-pad-right label 20))
(let* ((label-name
(make-label -1 -1 (pad-label (G_ "Name"))))
(label-home-directory
(make-label -1 -1 (pad-label (G_ "Home directory"))))
(entry-width 30)
(entry-name (make-entry -1 -1 entry-width))
(entry-home-directory (make-entry -1 -1 entry-width))
(entry-grid (make-grid 2 2))
(button-grid (make-grid 1 1))
(ok-button (make-button -1 -1 (G_ "OK")))
(grid (make-grid 1 2))
(title (G_ "User creation"))
(set-entry-grid-field
(cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
(form (make-form)))
(set-entry-grid-field 0 0 label-name)
(set-entry-grid-field 1 0 entry-name)
(set-entry-grid-field 0 1 label-home-directory)
(set-entry-grid-field 1 1 entry-home-directory)
(set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
(add-component-callback
entry-name
(lambda (component)
(set-entry-text entry-home-directory
(string-append "/home/" (entry-value entry-name)))))
(add-components-to-form form
label-name label-home-directory
entry-name entry-home-directory
ok-button)
(make-wrapped-grid-window (vertically-stacked-grid
GRID-ELEMENT-SUBGRID entry-grid
GRID-ELEMENT-SUBGRID button-grid)
title)
(let ((error-page
(lambda ()
(run-error-page (G_ "Empty inputs are not allowed.")
(G_ "Empty input")))))
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument ok-button)
(let ((name (entry-value entry-name))
(home-directory (entry-value entry-home-directory)))
(if (or (string=? name "")
(string=? home-directory ""))
(begin
(error-page)
(run-user-add-page))
(user
(name name)
(home-directory home-directory))))))))
(lambda ()
(destroy-form-and-pop form)))))))
(define (run-user-page)
(define (run users)
(let* ((listbox (make-listbox
-1 -1 10
(logior FLAG-SCROLL FLAG-BORDER)))
(info-textbox
(make-reflowed-textbox
-1 -1
(G_ "Please add at least one user to system\
using the 'Add' button.")
40 #:flags FLAG-BORDER))
(add-button (make-compact-button -1 -1 (G_ "Add")))
(del-button (make-compact-button -1 -1 (G_ "Delete")))
(listbox-button-grid
(apply
vertically-stacked-grid
GRID-ELEMENT-COMPONENT add-button
`(,@(if (null? users)
'()
(list GRID-ELEMENT-COMPONENT del-button)))))
(ok-button (make-button -1 -1 (G_ "OK")))
(exit-button (make-button -1 -1 (G_ "Exit")))
(title "User creation")
(grid
(vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
GRID-ELEMENT-COMPONENT listbox
GRID-ELEMENT-SUBGRID listbox-button-grid)
GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
GRID-ELEMENT-COMPONENT ok-button
GRID-ELEMENT-COMPONENT exit-button)))
(sorted-users (sort users (lambda (a b)
(string<= (user-name a)
(user-name b)))))
(listbox-elements
(map
(lambda (user)
`((key . ,(append-entry-to-listbox listbox
(user-name user)))
(user . ,user)))
sorted-users))
(form (make-form)))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(if (null? users)
(set-current-component form add-button)
(set-current-component form ok-button))
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument add-button)
(run (cons (run-user-add-page) users)))
((components=? argument del-button)
(let* ((current-user-key (current-listbox-entry listbox))
(users
(map (cut assoc-ref <> 'user)
(remove (lambda (element)
(equal? (assoc-ref element 'key)
current-user-key))
listbox-elements))))
(run users)))
((components=? argument ok-button)
(when (null? users)
(run-error-page (G_ "Please create at least one user.")
(G_ "No user"))
(run users))
users))))
(lambda ()
(destroy-form-and-pop form))))))
(run '()))

43
gnu/installer/newt/utils.scm Normal file
View File

@ -0,0 +1,43 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt utils)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (screen-columns
screen-rows
destroy-form-and-pop
set-screen-size!))
;; Number of columns and rows of the terminal.
(define screen-columns (make-parameter 0))
(define screen-rows (make-parameter 0))
(define (destroy-form-and-pop form)
"Destory the given FORM and pop the current window."
(destroy-form form)
(pop-window))
(define (set-screen-size!)
"Set the parameters 'screen-columns' and 'screen-rows' to the number of
columns and rows respectively of the current terminal."
(receive (columns rows)
(screen-size)
(screen-columns columns)
(screen-rows rows)))

118
gnu/installer/newt/welcome.scm Normal file
View File

@ -0,0 +1,118 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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
;;;
;;; 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 installer newt welcome)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
#:use-module (guix build syscalls)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (run-welcome-page))
;; Expected width and height for the logo.
(define logo-width (make-parameter 43))
(define logo-height (make-parameter 19))
(define info-textbox-width (make-parameter 70))
(define options-listbox-height (make-parameter 5))
(define* (run-menu-page title info-text logo
#:key
listbox-items
listbox-item->text)
"Run a page with the given TITLE, to ask the user to choose between
LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text
using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of
the page. Contrary to other pages, we cannot resort to grid layouts, because
we want this page to occupy all the screen space available."
(define (fill-listbox listbox items)
(map (lambda (item)
(let* ((text (listbox-item->text item))
(key (append-entry-to-listbox listbox text)))
(cons key item)))
items))
(let* ((logo-textbox
(make-textbox -1 -1 (logo-width) (logo-height) 0))
(info-textbox
(make-reflowed-textbox -1 -1
info-text
(info-textbox-width)))
(options-listbox
(make-listbox -1 -1
(options-listbox-height)
(logior FLAG-BORDER FLAG-RETURNEXIT)))
(keys (fill-listbox options-listbox listbox-items))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT logo-textbox
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT options-listbox))
(form (make-form)))
(set-textbox-text logo-textbox (read-all logo))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument options-listbox)
(let* ((entry (current-listbox-entry options-listbox))
(item (assoc-ref keys entry)))
(match item
((text . proc)
(proc))))))))
(lambda ()
(destroy-form-and-pop form))))))
(define (run-welcome-page logo)
"Run a welcome page with the given textual LOGO displayed at the center of
the page. Ask the user to choose between manual installation, graphical
installation and reboot."
(run-menu-page
(G_ "GNU GuixSD install")
(G_ "Welcome to GNU GuixSD installer!
Please note that the present graphical installer is still under heavy \
development, so you might want to prefer using the shell based process. \
The documentation is accessible at any time by pressing CTRL-ALT-F2.")
logo
#:listbox-items
`((,(G_ "Graphical install using a terminal based interface")
.
,(const #t))
(,(G_ "Install using the shell based process")
.
,(lambda ()
;; Switch to TTY3, where a root shell is available for shell based
;; install. The other root TTY's would have been ok too.
(system* "chvt" "3")
(run-welcome-page logo)))
(,(G_ "Reboot")
.
,(lambda ()
(newt-finish)
(reboot))))
#:listbox-item->text car))

243
gnu/installer/newt/wifi.scm Normal file
View File

@ -0,0 +1,243 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer newt wifi)
#:use-module (gnu installer connman)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt utils)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (guix records)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-wifi-page))
;; This record associates a connman service to its key the listbox.
(define-record-type* <service-item>
service-item make-service-item
service-item?
(service service-item-service) ; connman <service>
(key service-item-key)) ; newt listbox-key
(define (strength->string strength)
"Convert STRENGTH as an integer percentage into a text printable strength
bar using unicode characters. Taken from NetworkManager's
nmc_wifi_strength_bars."
(let ((quarter #\x2582)
(half #\x2584)
(three-quarter #\x2586)
(full #\x2588))
(cond
((> strength 80)
;; ▂▄▆█
(string quarter half three-quarter full))
((> strength 55)
;; ▂▄▆_
(string quarter half three-quarter #\_))
((> strength 30)
;; ▂▄__
(string quarter half #\_ #\_))
((> strength 5)
;; ▂___
(string quarter #\_ #\_ #\_))
(else
;; ____
(string quarter #\_ #\_ #\_ #\_)))))
(define (force-wifi-scan)
"Force a wifi scan. Raise a condition if no wifi technology is available."
(let* ((technologies (connman-technologies))
(wifi-technology
(find (lambda (technology)
(string=? (technology-type technology) "wifi"))
technologies)))
(if wifi-technology
(connman-scan-technology wifi-technology)
(raise (condition
(&message
(message (G_ "Unable to find a wifi technology"))))))))
(define (draw-scanning-page)
"Draw a page to indicate a wifi scan in in progress."
(draw-info-page (G_ "Scanning wifi for available networks, please wait.")
(G_ "Scan in progress")))
(define (run-wifi-password-page)
"Run a page prompting user for a password and return it."
(run-input-page (G_ "Please enter the wifi password.")
(G_ "Password required")))
(define (run-wrong-password-page service-name)
"Run a page to inform user of a wrong password input."
(run-error-page
(format #f (G_ "The password you entered for ~a is incorrect.")
service-name)
(G_ "Wrong password")))
(define (run-unknown-error-page service-name)
"Run a page to inform user that a connection error happened."
(run-error-page
(format #f
(G_ "An error occured while trying to connect to ~a, please retry.")
service-name)
(G_ "Connection error")))
(define (password-callback)
(run-wifi-password-page))
(define (connect-wifi-service listbox service-items)
"Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list
of <service-item> records present in LISTBOX."
(let* ((listbox-key (current-listbox-entry listbox))
(item (find (lambda (item)
(eq? (service-item-key item) listbox-key))
service-items))
(service (service-item-service item))
(service-name (service-name service))
(form (draw-connecting-page service-name)))
(dynamic-wind
(const #t)
(lambda ()
(guard (c ((connman-password-error? c)
(run-wrong-password-page service-name)
#f)
((connman-already-connected-error? c)
#t)
((connman-connection-error? c)
(run-unknown-error-page service-name)
#f))
(connman-connect-with-auth service password-callback)))
(lambda ()
(destroy-form-and-pop form)))))
(define (run-wifi-scan-page)
"Force a wifi scan and draw a page during the operation."
(let ((form (draw-scanning-page)))
(force-wifi-scan)
(destroy-form-and-pop form)))
(define (wifi-services)
"Return all the connman services of wifi type."
(let ((services (connman-services)))
(filter (lambda (service)
(and (string=? (service-type service) "wifi")
(not (string-null? (service-name service)))))
services)))
(define* (fill-wifi-services listbox wifi-services)
"Append all the services in WIFI-SERVICES to the given LISTBOX."
(clear-listbox listbox)
(map (lambda (service)
(let* ((text (service->text service))
(key (append-entry-to-listbox listbox text)))
(service-item
(service service)
(key key))))
wifi-services))
;; Maximum length of a wifi service name.
(define service-name-max-length (make-parameter 20))
;; Heigth of the listbox displaying wifi services.
(define wifi-listbox-heigth (make-parameter 20))
;; Information textbox width.
(define info-textbox-width (make-parameter 40))
(define (service->text service)
"Return a string composed of the name and the strength of the given
SERVICE. A '*' preceding the service name indicates that it is connected."
(let* ((name (service-name service))
(padded-name (string-pad-right name
(service-name-max-length)))
(strength (service-strength service))
(strength-string (strength->string strength))
(state (service-state service))
(connected? (or (string=? state "online")
(string=? state "ready"))))
(format #f "~c ~a ~a~%"
(if connected? #\* #\ )
padded-name
strength-string)))
(define (run-wifi-page)
"Run a page displaying available wifi networks in a listbox. Connect to the
network when the corresponding listbox entry is selected. A button allow to
force a wifi scan."
(let* ((listbox (make-listbox
-1 -1
(wifi-listbox-heigth)
(logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT)))
(form (make-form))
(buttons-grid (make-grid 1 1))
(middle-grid (make-grid 2 1))
(info-text (G_ "Please select a wifi network."))
(info-textbox
(make-reflowed-textbox -1 -1 info-text
(info-textbox-width)
#:flags FLAG-BORDER))
(exit-button (make-button -1 -1 (G_ "Exit")))
(scan-button (make-button -1 -1 (G_ "Scan")))
(services (wifi-services))
(service-items '()))
(if (null? services)
(append-entry-to-listbox listbox (G_ "No wifi detected"))
(set! service-items (fill-wifi-services listbox services)))
(set-grid-field middle-grid 0 0 GRID-ELEMENT-COMPONENT listbox)
(set-grid-field middle-grid 1 0 GRID-ELEMENT-COMPONENT scan-button
#:anchor ANCHOR-TOP
#:pad-left 2)
(set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT exit-button)
(add-components-to-form form
info-textbox
listbox scan-button
exit-button)
(make-wrapped-grid-window
(basic-window-grid info-textbox middle-grid buttons-grid)
(G_ "Wifi"))
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument scan-button)
(run-wifi-scan-page)
(run-wifi-page))
((components=? argument exit-button)
(raise
(condition
(&installer-step-abort))))
((components=? argument listbox)
(let ((result (connect-wifi-service listbox service-items)))
(unless result
(run-wifi-page)))))))
(lambda ()
(destroy-form-and-pop form))))))

1312
gnu/installer/parted.scm Normal file
View File

File diff suppressed because it is too large Load Diff

84
gnu/installer/record.scm Normal file
View File

@ -0,0 +1,84 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer record)
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:export (<installer>
installer
make-installer
installer?
installer-name
installer-init
installer-exit
installer-exit-error
installer-final-page
installer-keymap-page
installer-locale-page
installer-menu-page
installer-network-page
installer-timezone-page
installer-hostname-page
installer-user-page
installer-partition-page
installer-services-page
installer-welcome-page))
;;;
;;; Installer record.
;;;
;; The <installer> record contains pages that will be run to prompt the user
;; for the system configuration. The goal of the installer is to produce a
;; complete <operating-system> record and install it.
(define-record-type* <installer>
installer make-installer
installer?
;; symbol
(name installer-name)
;; procedure: void -> void
(init installer-init)
;; procedure: void -> void
(exit installer-exit)
;; procedure (key arguments) -> void
(exit-error installer-exit-error)
;; procedure void -> void
(final-page installer-final-page)
;; procedure (layouts) -> (list layout variant)
(keymap-page installer-keymap-page)
;; procedure: (#:key supported-locales iso639-languages iso3166-territories)
;; -> glibc-locale
(locale-page installer-locale-page)
;; procedure: (steps) -> step-id
(menu-page installer-menu-page)
;; procedure void -> void
(network-page installer-network-page)
;; procedure (zonetab) -> posix-timezone
(timezone-page installer-timezone-page)
;; procedure void -> void
(hostname-page installer-hostname-page)
;; procedure void -> void
(user-page installer-user-page)
;; procedure void -> void
(partition-page installer-partition-page)
;; procedure void -> void
(services-page installer-services-page)
;; procedure (logo) -> void
(welcome-page installer-welcome-page))

59
gnu/installer/services.scm Normal file
View File

@ -0,0 +1,59 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer services)
#:use-module (guix records)
#:export (<desktop-environment>
desktop-environment
make-desktop-environment
desktop-environment-name
desktop-environment-snippet
%desktop-environments
desktop-environments->configuration))
(define-record-type* <desktop-environment>
desktop-environment make-desktop-environment
desktop-environment?
(name desktop-environment-name) ;string
(snippet desktop-environment-snippet)) ;symbol
;; This is the list of desktop environments supported as services.
(define %desktop-environments
(list
(desktop-environment
(name "GNOME")
(snippet '(gnome-desktop-service)))
(desktop-environment
(name "Xfce")
(snippet '(xfce-desktop-service)))
(desktop-environment
(name "MATE")
(snippet '(mate-desktop-service)))
(desktop-environment
(name "Enlightenment")
(snippet '(service enlightenment-desktop-service-type)))))
(define (desktop-environments->configuration desktop-environments)
"Return the configuration field for DESKTOP-ENVIRONMENTS."
(let ((snippets
(map desktop-environment-snippet desktop-environments)))
`(,@(if (null? snippets)
'()
`((services (cons* ,@snippets
%desktop-services)))))))

237
gnu/installer/steps.scm Normal file
View File

@ -0,0 +1,237 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer steps)
#:use-module (guix records)
#:use-module (guix build utils)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (rnrs io ports)
#:export (&installer-step-abort
installer-step-abort?
&installer-step-break
installer-step-break?
<installer-step>
installer-step
make-installer-step
installer-step?
installer-step-id
installer-step-description
installer-step-compute
installer-step-configuration-formatter
run-installer-steps
find-step-by-id
result->step-ids
result-step
result-step-done?
%installer-configuration-file
%installer-target-dir
%configuration-file-width
format-configuration
configuration->file))
;; This condition may be raised to abort the current step.
(define-condition-type &installer-step-abort &condition
installer-step-abort?)
;; This condition may be raised to break out from the steps execution.
(define-condition-type &installer-step-break &condition
installer-step-break?)
;; An installer-step record is basically an id associated to a compute
;; procedure. The COMPUTE procedure takes exactly one argument, an association
;; list containing the results of previously executed installer-steps (see
;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE
;; procedure will be stored in the results list passed to the next
;; installer-step and so on.
(define-record-type* <installer-step>
installer-step make-installer-step
installer-step?
(id installer-step-id) ;symbol
(description installer-step-description ;string
(default #f))
(compute installer-step-compute) ;procedure
(configuration-formatter installer-step-configuration-formatter ;procedure
(default #f)))
(define* (run-installer-steps #:key
steps
(rewind-strategy 'previous)
(menu-proc (const #f)))
"Run the COMPUTE procedure of all <installer-step> records in STEPS
sequencially. If the &installer-step-abort condition is raised, fallback to a
previous install-step, accordingly to the specified REWIND-STRATEGY.
REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous
is selected, the execution will resume at the previous installer-step. If
'menu is selected, the MENU-PROC procedure will be called. Its return value
has to be an installer-step ID to jump to. The ID has to be the one of a
previously executed step. It is impossible to jump forward. Finally if 'start
is selected, the execution will resume at the first installer-step.
The result of every COMPUTE procedures is stored in an association list, under
the form:
'((STEP-ID . COMPUTE-RESULT) ...)
where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
result of the associated COMPUTE procedure. This result association list is
passed as argument of every COMPUTE procedure. It is finally returned when the
computation is over.
If the &installer-step-break condition is raised, stop the computation and
return the accumalated result so far."
(define (pop-result list)
(cdr list))
(define (first-step? steps step)
(match steps
((first-step . rest-steps)
(equal? first-step step))))
(define* (skip-to-step step result
#:key todo-steps done-steps)
(match (list todo-steps done-steps)
(((todo . rest-todo) (prev-done ... last-done))
(if (eq? (installer-step-id todo)
(installer-step-id step))
(run result
#:todo-steps todo-steps
#:done-steps done-steps)
(skip-to-step step (pop-result result)
#:todo-steps (cons last-done todo-steps)
#:done-steps prev-done)))))
(define* (run result #:key todo-steps done-steps)
(match todo-steps
(() (reverse result))
((step . rest-steps)
(guard (c ((installer-step-abort? c)
(case rewind-strategy
((previous)
(match done-steps
(()
;; We cannot go previous the first step. So re-raise
;; the exception. It might be useful in the case of
;; nested run-installer-steps. Abort to 'raise-above
;; prompt to prevent the condition from being catched
;; by one of the previously installed guard.
(abort-to-prompt 'raise-above c))
((prev-done ... last-done)
(run (pop-result result)
#:todo-steps (cons last-done todo-steps)
#:done-steps prev-done))))
((menu)
(let ((goto-step (menu-proc
(append done-steps (list step)))))
(if (eq? goto-step step)
(run result
#:todo-steps todo-steps
#:done-steps done-steps)
(skip-to-step goto-step result
#:todo-steps todo-steps
#:done-steps done-steps))))
((start)
(if (null? done-steps)
;; Same as above, it makes no sense to jump to start
;; when we are at the first installer-step. Abort to
;; 'raise-above prompt to re-raise the condition.
(abort-to-prompt 'raise-above c)
(run '()
#:todo-steps steps
#:done-steps '())))))
((installer-step-break? c)
(reverse result)))
(let* ((id (installer-step-id step))
(compute (installer-step-compute step))
(res (compute result done-steps)))
(run (alist-cons id res result)
#:todo-steps rest-steps
#:done-steps (append done-steps (list step))))))))
(call-with-prompt 'raise-above
(lambda ()
(run '()
#:todo-steps steps
#:done-steps '()))
(lambda (k condition)
(raise condition))))
(define (find-step-by-id steps id)
"Find and return the step in STEPS whose id is equal to ID."
(find (lambda (step)
(eq? (installer-step-id step) id))
steps))
(define (result-step results step-id)
"Return the result of the installer-step specified by STEP-ID in
RESULTS."
(assoc-ref results step-id))
(define (result-step-done? results step-id)
"Return #t if the installer-step specified by STEP-ID has a COMPUTE value
stored in RESULTS. Return #f otherwise."
(and (assoc step-id results) #t))
(define %installer-configuration-file (make-parameter "/mnt/etc/config.scm"))
(define %installer-target-dir (make-parameter "/mnt"))
(define %configuration-file-width (make-parameter 79))
(define (format-configuration steps results)
"Return the list resulting from the application of the procedure defined in
CONFIGURATION-FORMATTER field of <installer-step> on the associated result
found in RESULTS."
(let ((configuration
(append-map
(lambda (step)
(let* ((step-id (installer-step-id step))
(conf-formatter
(installer-step-configuration-formatter step))
(result-step (result-step results step-id)))
(if (and result-step conf-formatter)
(conf-formatter result-step)
'())))
steps))
(modules '((use-modules (gnu))
(use-service-modules desktop))))
`(,@modules
()
(operating-system ,@configuration))))
(define* (configuration->file configuration
#:key (filename (%installer-configuration-file)))
"Write the given CONFIGURATION to FILENAME."
(mkdir-p (dirname filename))
(call-with-output-file filename
(lambda (port)
(format port ";; This is an operating system configuration generated~%")
(format port ";; by the graphical installer.~%")
(newline port)
(for-each (lambda (part)
(if (null? part)
(newline port)
(pretty-print part port)))
configuration)
(flush-output-port port))))

127
gnu/installer/timezone.scm Normal file
View File

@ -0,0 +1,127 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer timezone)
#:use-module (gnu installer utils)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:export (locate-childrens
timezone->posix-tz
timezone-has-child?
zonetab->timezone-tree
posix-tz->configuration))
(define %not-blank
(char-set-complement char-set:blank))
(define (posix-tz->timezone tz)
"Convert given TZ in Posix format like \"Europe/Paris\" into a list like
(\"Europe\" \"Paris\")."
(string-split tz #\/))
(define (timezone->posix-tz timezone)
"Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone
like \"Europe/Paris\"."
(string-join timezone "/"))
(define (zonetab->timezones zonetab)
"Parse ZONETAB file and return the corresponding list of timezones."
(define (zonetab-line->posix-tz line)
(let ((tokens (string-tokenize line %not-blank)))
(match tokens
((code coordinates tz _ ...)
tz))))
(call-with-input-file zonetab
(lambda (port)
(let* ((lines (read-lines port))
;; Filter comment lines starting with '#' character.
(tz-lines (filter (lambda (line)
(not (eq? (string-ref line 0)
#\#)))
lines)))
(map (lambda (line)
(posix-tz->timezone
(zonetab-line->posix-tz line)))
tz-lines)))))
(define (timezones->timezone-tree timezones)
"Convert the list of timezones, TIMEZONES into a tree under the form:
(\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\"))
representing America/North_Dakota/New_Salem and America/North_Dakota/Center
timezones."
(define (remove-first lists)
"Remove the first element of every sublists in the argument LISTS."
(map (lambda (list)
(if (null? list) list (cdr list)))
lists))
(let loop ((cur-timezones timezones))
(match cur-timezones
(() '())
(((region . rest-region) . rest-timezones)
(if (null? rest-region)
(cons (list region) (loop rest-timezones))
(receive (same-region other-region)
(partition (lambda (timezone)
(string=? (car timezone) region))
cur-timezones)
(acons region
(loop (remove-first same-region))
(loop other-region))))))))
(define (locate-childrens tree path)
"Return the childrens of the timezone indicated by PATH in the given
TREE. Raise a condition if the PATH could not be found."
(let ((extract-proc (cut map car <>)))
(match path
(() (sort (extract-proc tree) string<?))
((region . rest)
(or (and=> (assoc-ref tree region)
(cut locate-childrens <> rest))
(raise
(condition
(&message
(message
(format #f (G_ "Unable to locate path: ~a.") path))))))))))
(define (timezone-has-child? tree timezone)
"Return #t if the given TIMEZONE any child in TREE and #f otherwise."
(not (null? (locate-childrens tree timezone))))
(define* (zonetab->timezone-tree zonetab)
"Return the timezone tree corresponding to the given ZONETAB file."
(timezones->timezone-tree (zonetab->timezones zonetab)))
;;;
;;; Configuration formatter.
;;;
(define (posix-tz->configuration timezone)
"Return the configuration field for TIMEZONE."
`((timezone ,timezone)))

50
gnu/installer/user.scm Normal file
View File

@ -0,0 +1,50 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer user)
#:use-module (guix records)
#:export (<user>
user
make-user
user-name
user-group
user-home-directory
users->configuration))
(define-record-type* <user>
user make-user
user?
(name user-name)
(group user-group
(default "users"))
(home-directory user-home-directory))
(define (users->configuration users)
"Return the configuration field for USERS."
`((users (cons*
,@(map (lambda (user)
`(user-account
(name ,(user-name user))
(group ,(user-group user))
(home-directory ,(user-home-directory user))
(supplementary-groups
(quote ("wheel" "netdev"
"audio" "video")))))
users)
%base-user-accounts))))

63
gnu/installer/utils.scm Normal file
View File

@ -0,0 +1,63 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 installer utils)
#:use-module (guix utils)
#:use-module (guix build utils)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 textual-ports)
#:export (read-lines
read-all
nearest-exact-integer
read-percentage
run-shell-command))
(define* (read-lines #:optional (port (current-input-port)))
"Read lines from PORT and return them as a list."
(let loop ((line (read-line port))
(lines '()))
(if (eof-object? line)
(reverse lines)
(loop (read-line port)
(cons line lines)))))
(define (read-all file)
"Return the content of the given FILE as a string."
(call-with-input-file file
get-string-all))
(define (nearest-exact-integer x)
"Given a real number X, return the nearest exact integer, with ties going to
the nearest exact even integer."
(inexact->exact (round x)))
(define (read-percentage percentage)
"Read PERCENTAGE string and return the corresponding percentage as a
number. If no percentage is found, return #f"
(let ((result (string-match "^([0-9]+)%$" percentage)))
(and result
(string->number (match:substring result 1)))))
(define (run-shell-command command)
(call-with-temporary-output-file
(lambda (file port)
(format port "~a~%" command)
;; (format port "exit~%")
(close port)
(invoke "bash" "--init-file" file))))

55
gnu/local.mk
View File

@ -46,6 +46,7 @@ GNU_SYSTEM_MODULES = \
%D%/bootloader/grub.scm \
%D%/bootloader/extlinux.scm \
%D%/bootloader/u-boot.scm \
%D%/ci.scm \
%D%/packages.scm \
%D%/packages/abduco.scm \
%D%/packages/abiword.scm \
@ -112,6 +113,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/conky.scm \
%D%/packages/connman.scm \
%D%/packages/cook.scm \
%D%/packages/coq.scm \
%D%/packages/cpio.scm \
%D%/packages/cpp.scm \
%D%/packages/cppi.scm \
@ -126,6 +128,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/datamash.scm \
%D%/packages/datastructures.scm \
%D%/packages/dav.scm \
%D%/packages/dbm.scm \
%D%/packages/dc.scm \
%D%/packages/debian.scm \
%D%/packages/debug.scm \
@ -154,6 +157,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/elixir.scm \
%D%/packages/embedded.scm \
%D%/packages/emacs.scm \
%D%/packages/emacs-xyz.scm \
%D%/packages/emulators.scm \
%D%/packages/enchant.scm \
%D%/packages/engineering.scm \
@ -348,6 +352,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/pem.scm \
%D%/packages/perl.scm \
%D%/packages/perl-check.scm \
%D%/packages/perl-compression.scm \
%D%/packages/perl-web.scm \
%D%/packages/photo.scm \
%D%/packages/phabricator.scm \
@ -366,8 +371,10 @@ GNU_SYSTEM_MODULES = \
%D%/packages/pure.scm \
%D%/packages/pv.scm \
%D%/packages/python.scm \
%D%/packages/python-compression.scm \
%D%/packages/python-crypto.scm \
%D%/packages/python-web.scm \
%D%/packages/python-xyz.scm \
%D%/packages/toys.scm \
%D%/packages/tryton.scm \
%D%/packages/qt.scm \
@ -410,6 +417,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/sml.scm \
%D%/packages/speech.scm \
%D%/packages/spice.scm \
%D%/packages/sqlite.scm \
%D%/packages/ssh.scm \
%D%/packages/sssd.scm \
%D%/packages/stalonetray.scm \
@ -555,9 +563,47 @@ GNU_SYSTEM_MODULES = \
%D%/tests/ssh.scm \
%D%/tests/version-control.scm \
%D%/tests/virtualization.scm \
%D%/tests/web.scm \
%D%/tests/web.scm
if ENABLE_INSTALLER
GNU_SYSTEM_MODULES += \
%D%/installer.scm \
%D%/installer/connman.scm \
%D%/installer/final.scm \
%D%/installer/hostname.scm \
%D%/installer/keymap.scm \
%D%/installer/locale.scm \
%D%/installer/newt.scm \
%D%/installer/parted.scm \
%D%/installer/record.scm \
%D%/installer/services.scm \
%D%/installer/steps.scm \
%D%/installer/timezone.scm \
%D%/installer/user.scm \
%D%/installer/utils.scm \
\
%D%/ci.scm
%D%/installer/newt/ethernet.scm \
%D%/installer/newt/final.scm \
%D%/installer/newt/hostname.scm \
%D%/installer/newt/keymap.scm \
%D%/installer/newt/locale.scm \
%D%/installer/newt/menu.scm \
%D%/installer/newt/network.scm \
%D%/installer/newt/page.scm \
%D%/installer/newt/partition.scm \
%D%/installer/newt/services.scm \
%D%/installer/newt/timezone.scm \
%D%/installer/newt/utils.scm \
%D%/installer/newt/welcome.scm \
%D%/installer/newt/wifi.scm
installerdir = $(guilemoduledir)/%D%/installer
dist_installer_DATA = \
%D%/installer/aux-files/logo.txt \
%D%/installer/aux-files/SUPPORTED
endif ENABLE_INSTALLER
# Modules that do not need to be compiled.
MODULES_NOT_COMPILED += \
@ -866,6 +912,7 @@ dist_patch_DATA = \
%D%/packages/patches/kinit-kdeinit-libpath.patch \
%D%/packages/patches/kio-search-smbd-on-PATH.patch \
%D%/packages/patches/kmod-module-directory.patch \
%D%/packages/patches/kmscon-runtime-keymap-switch.patch \
%D%/packages/patches/kpackage-allow-external-paths.patch \
%D%/packages/patches/kobodeluxe-paths.patch \
%D%/packages/patches/kobodeluxe-enemies-pipe-decl.patch \
@ -873,6 +920,7 @@ dist_patch_DATA = \
%D%/packages/patches/kobodeluxe-manpage-minus-not-hyphen.patch \
%D%/packages/patches/kobodeluxe-midicon-segmentation-fault.patch \
%D%/packages/patches/kobodeluxe-graphics-window-signed-char.patch \
%D%/packages/patches/kodi-skip-test-449.patch \
%D%/packages/patches/laby-make-install.patch \
%D%/packages/patches/ldc-bootstrap-disable-tests.patch \
%D%/packages/patches/ldc-disable-phobos-tests.patch \
@ -929,7 +977,6 @@ dist_patch_DATA = \
%D%/packages/patches/libsndfile-CVE-2017-8361-8363-8365.patch \
%D%/packages/patches/libsndfile-CVE-2017-8362.patch \
%D%/packages/patches/libsndfile-CVE-2017-12562.patch \
%D%/packages/patches/libssh-hostname-parser-bug.patch \
%D%/packages/patches/libssh2-fix-build-failure-with-gcrypt.patch \
%D%/packages/patches/libtar-CVE-2013-4420.patch \
%D%/packages/patches/libtheora-config-guess.patch \
@ -1029,11 +1076,13 @@ dist_patch_DATA = \
%D%/packages/patches/ola-readdir-r.patch \
%D%/packages/patches/openbabel-fix-crash-on-nwchem-output.patch \
%D%/packages/patches/opencascade-oce-glibc-2.26.patch \
%D%/packages/patches/opencv-rgbd-aarch64-test-fix.patch \
%D%/packages/patches/openfoam-4.1-cleanup.patch \
%D%/packages/patches/openjdk-10-idlj-reproducibility.patch \
%D%/packages/patches/openldap-CVE-2017-9287.patch \
%D%/packages/patches/openocd-nrf52.patch \
%D%/packages/patches/opensmtpd-fix-crash.patch \
%D%/packages/patches/openssh-CVE-2018-20685.patch \
%D%/packages/patches/openssl-runpath.patch \
%D%/packages/patches/openssl-1.1-c-rehash-in.patch \
%D%/packages/patches/openssl-c-rehash-in.patch \

253
gnu/packages.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
@ -28,11 +28,14 @@
#:use-module (guix memoization)
#:use-module ((guix build utils)
#:select ((package-name->name+version
. hyphen-separated-name->name+version)))
. hyphen-separated-name->name+version)
mkdir-p))
#:autoload (guix profiles) (packages->manifest)
#:use-module (guix describe)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:autoload (ice-9 binary-ports) (put-bytevector)
#:autoload (system base compile) (compile)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@ -50,14 +53,18 @@
%default-package-module-path
fold-packages
fold-available-packages
find-packages-by-name
find-package-locations
find-best-packages-by-name
find-newest-available-packages
specification->package
specification->package+output
specifications->manifest))
specification->location
specifications->manifest
generate-package-cache))
;;; Commentary:
;;;
@ -136,6 +143,14 @@ for system '~a'")
;; Default search path for package modules.
`((,%distro-root-directory . "gnu/packages")))
(define (cache-is-authoritative?)
"Return true if the pre-computed package cache is authoritative. It is not
authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L'
flags."
(equal? (%package-module-path)
(append %default-package-module-path
(package-path-entries))))
(define %package-module-path
;; Search path for package modules. Each item must be either a directory
;; name or a pair whose car is a directory and whose cdr is a sub-directory
@ -168,6 +183,50 @@ for system '~a'")
directory))
%load-path)))
(define (fold-available-packages proc init)
"Fold PROC over the list of available packages. For each available package,
PROC is called along these lines:
(PROC NAME VERSION RESULT
#:outputs OUTPUTS
#:location LOCATION
…)
PROC can use #:allow-other-keys to ignore the bits it's not interested in.
When a package cache is available, this procedure does not actually load any
package module."
(define cache
(load-package-cache (current-profile)))
(if (and cache (cache-is-authoritative?))
(vhash-fold (lambda (name vector result)
(match vector
(#(name version module symbol outputs
supported? deprecated?
file line column)
(proc name version result
#:outputs outputs
#:location (and file
(location file line column))
#:supported? supported?
#:deprecated? deprecated?))))
init
cache)
(fold-packages (lambda (package result)
(proc (package-name package)
(package-version package)
result
#:outputs (package-outputs package)
#:location (package-location package)
#:supported?
(->bool
(member (%current-system)
(package-supported-systems package)))
#:deprecated?
(->bool
(package-superseded package))))
init)))
(define* (fold-packages proc init
#:optional
(modules (all-modules (%package-module-path)
@ -184,7 +243,35 @@ is guaranteed to never traverse the same package twice."
init
modules))
(define find-packages-by-name
(define %package-cache-file
;; Location of the package cache.
"/lib/guix/package.cache")
(define load-package-cache
(mlambda (profile)
"Attempt to load the package cache. On success return a vhash keyed by
package names. Return #f on failure."
(match profile
(#f #f)
(profile
(catch 'system-error
(lambda ()
(define lst
(load-compiled (string-append profile %package-cache-file)))
(fold (lambda (item vhash)
(match item
(#(name version module symbol outputs
supported? deprecated?
file line column)
(vhash-cons name item vhash))))
vlist-null
lst))
(lambda args
(if (= ENOENT (system-error-errno args))
#f
(apply throw args))))))))
(define find-packages-by-name/direct ;bypass the cache
(let ((packages (delay
(fold-packages (lambda (p r)
(vhash-cons (package-name p) p r))
@ -203,28 +290,61 @@ decreasing version order."
matching)
matching)))))
(define find-newest-available-packages
(mlambda ()
"Return a vhash keyed by package names, and with
associated values of the form
(define (cache-lookup cache name)
"Lookup package NAME in CACHE. Return a list sorted in increasing version
order."
(define (package-version<? v1 v2)
(version>? (vector-ref v2 1) (vector-ref v1 1)))
(newest-version newest-package ...)
(sort (vhash-fold* cons '() name cache)
package-version<?))
where the preferred package is listed first."
(define* (find-packages-by-name name #:optional version)
"Return the list of packages with the given NAME. If VERSION is not #f,
then only return packages whose version is prefixed by VERSION, sorted in
decreasing version order."
(define cache
(load-package-cache (current-profile)))
;; FIXME: Currently, the preferred package is whichever one
;; was found last by 'fold-packages'. Find a better solution.
(fold-packages (lambda (p r)
(let ((name (package-name p))
(version (package-version p)))
(match (vhash-assoc name r)
((_ newest-so-far . pkgs)
(case (version-compare version newest-so-far)
((>) (vhash-cons name `(,version ,p) r))
((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r)))
(#f (vhash-cons name `(,version ,p) r)))))
vlist-null)))
(if (and (cache-is-authoritative?) cache)
(match (cache-lookup cache name)
(#f #f)
((#(_ versions modules symbols _ _ _ _ _ _) ...)
(fold (lambda (version* module symbol result)
(if (or (not version)
(version-prefix? version version*))
(cons (module-ref (resolve-interface module)
symbol)
result)
result))
'()
versions modules symbols)))
(find-packages-by-name/direct name version)))
(define* (find-package-locations name #:optional version)
"Return a list of version/location pairs corresponding to each package
matching NAME and VERSION."
(define cache
(load-package-cache (current-profile)))
(if (and cache (cache-is-authoritative?))
(match (cache-lookup cache name)
(#f '())
((#(name versions modules symbols outputs
supported? deprecated?
files lines columns) ...)
(fold (lambda (version* file line column result)
(if (and file
(or (not version)
(version-prefix? version version*)))
(alist-cons version* (location file line column)
result)
result))
'()
versions files lines columns)))
(map (lambda (package)
(cons (package-version package) (package-location package)))
(find-packages-by-name/direct name version))))
(define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest
@ -232,9 +352,64 @@ version numbers; otherwise, return the list of packages named NAME and at
VERSION."
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (find-newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))
(match (find-packages-by-name name)
(()
'())
((matches ...)
;; Return the subset of MATCHES with the higher version number.
(let ((highest (package-version (first matches))))
(take-while (lambda (p)
(string=? (package-version p) highest))
matches))))))
(define (generate-package-cache directory)
"Generate under DIRECTORY a cache of all the available packages.
The primary purpose of the cache is to speed up package lookup by name such
that we don't have to traverse and load all the package modules, thereby also
reducing the memory footprint."
(define cache-file
(string-append directory %package-cache-file))
(define (expand-cache module symbol variable result)
(match (false-if-exception (variable-ref variable))
((? package? package)
(if (hidden-package? package)
result
(cons `#(,(package-name package)
,(package-version package)
,(module-name module)
,symbol
,(package-outputs package)
,(->bool (member (%current-system)
(package-supported-systems package)))
,(->bool (package-superseded package))
,@(let ((loc (package-location package)))
(if loc
`(,(location-file loc)
,(location-line loc)
,(location-column loc))
'(#f #f #f))))
result)))
(_
result)))
(define exp
(fold-module-public-variables* expand-cache '()
(all-modules (%package-module-path)
#:warn
warn-about-load-error)))
(mkdir-p (dirname cache-file))
(call-with-output-file cache-file
(lambda (port)
;; Store the cache as a '.go' file. This makes loading fast and reduces
;; heap usage since some of the static data is directly mmapped.
(put-bytevector port
(compile `'(,@exp)
#:to 'bytecode
#:opts '(#:to-file? #t)))))
cache-file)
(define %sigint-prompt
@ -290,6 +465,30 @@ present, return the preferred newest version."
(let-values (((name version) (package-name->name+version spec)))
(%find-package spec name version)))
(define (specification->location spec)
"Return the location of the highest-numbered package matching SPEC, a
specification such as \"guile@2\" or \"emacs\"."
(let-values (((name version) (package-name->name+version spec)))
(match (find-package-locations name version)
(()
(if version
(leave (G_ "~A: package not found for version ~a~%") name version)
(leave (G_ "~A: unknown package~%") name)))
(lst
(let* ((highest (match lst (((version . _) _ ...) version)))
(locations (take-while (match-lambda
((version . location)
(string=? version highest)))
lst)))
(match locations
(((version . location) . rest)
(unless (null? rest)
(warning (G_ "ambiguous package specification `~a'~%") spec)
(warning (G_ "choosing ~a@~a from ~a~%")
name version
(location->string location)))
location)))))))
(define* (specification->package+output spec #:optional (output "out"))
"Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:

3
gnu/packages/ada.scm
View File

@ -26,7 +26,8 @@
#:use-module (gnu packages)
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages python))
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz))
(define-public python2-langkit
(let ((commit "fe0bc8bf60dbd2937759810df76ac420d99fc15f")

7
gnu/packages/admin.scm
View File

@ -13,7 +13,7 @@
;;; Copyright © 2016 Peter Feigl <peter.feigl@nexoid.at>
;;; Copyright © 2016 John J. Foerch <jjfoerch@earthlink.net>
;;; Copyright © 2016, 2017 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2016, 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2016, 2017, 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2017 Ben Sturmfels <ben@sturm.com.au>
;;; Copyright © 2017 Ethan R. Jones <doubleplusgood23@gmail.com>
@ -86,6 +86,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages terminals)
#:use-module (gnu packages texinfo)
@ -1510,7 +1511,7 @@ various ways that may be running with too much privilege.")
(define-public smartmontools
(package
(name "smartmontools")
(version "6.6")
(version "7.0")
(source (origin
(method url-fetch)
(uri (string-append
@ -1518,7 +1519,7 @@ various ways that may be running with too much privilege.")
version "/smartmontools-" version ".tar.gz"))
(sha256
(base32
"0m1hllbb78rr6cxkbalmz1gqkl0psgq8rrmv4gwcmz34n07kvx2i"))))
"077nx2rn9szrg6isdh0938zbp7vr3dsyxl4jdyyzv1xwhqksrqg5"))))
(build-system gnu-build-system)
(inputs `(("libcap-ng" ,libcap-ng)))
(home-page "https://www.smartmontools.org/")

32
gnu/packages/adns.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -21,6 +22,7 @@
#:use-module (guix licenses)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (gnu packages pkg-config))
@ -80,3 +82,33 @@ queries without blocking, or need to perform multiple DNS queries in parallel.
The primary examples of such applications are servers which communicate with
multiple clients and programs with graphical user interfaces.")
(license (x11-style "https://c-ares.haxx.se/license.html"))))
;; XXX: temporary package for tensorflow / grpc
(define-public c-ares-next
(package
(name "c-ares")
(version "1.15.0")
(source (origin
(method url-fetch)
(uri (string-append
"https://c-ares.haxx.se/download/" name "-" version
".tar.gz"))
(sha256
(base32
"0lk8knip4xk6qzksdkn7085mmgm4ixfczdyyjw656c193y3rgnvc"))))
(build-system cmake-build-system)
(arguments
`(#:tests? #f ; some tests seem to require Internet connection
#:configure-flags
(list "-DCARES_BUILD_TESTS=ON")))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "https://c-ares.haxx.se/")
(synopsis "C library for asynchronous DNS requests")
(description
"C-ares is a C library that performs DNS requests and name resolution
asynchronously. It is intended for applications which need to perform DNS
queries without blocking, or need to perform multiple DNS queries in parallel.
The primary examples of such applications are servers which communicate with
multiple clients and programs with graphical user interfaces.")
(license (x11-style "https://c-ares.haxx.se/license.html"))))

1
gnu/packages/android.scm
View File

@ -41,6 +41,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages selinux)
#:use-module (gnu packages serialization)
#:use-module (gnu packages ssh)

42
gnu/packages/animation.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Pkill -9 <pkill9@runbox.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -258,3 +259,44 @@ easy to lip sync animated characters by making the process very simple – just
type in the words being spoken, then drag the words on top of the sound’s
waveform until they line up with the proper sounds.")
(license license:gpl3+))))
(define-public pencil2d
(package
(name "pencil2d")
(version "0.6.2")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/pencil2d/pencil")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1iv7drwxs32mqs3hybjx2lxyqn8cv2b4rw9ny7gzdacsbhi65knr"))))
(build-system gnu-build-system)
(inputs
`(("qtbase" ,qtbase)
("qtxmlpatterns" ,qtxmlpatterns)
("qtmultimedia" ,qtmultimedia)
("qtsvg" ,qtsvg)))
(arguments
`(#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key inputs outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(invoke "qmake" (string-append "PREFIX=" out)))))
(add-after 'install 'wrap-executable
(lambda* (#:key inputs outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(plugin-path (getenv "QT_PLUGIN_PATH")))
(wrap-program (string-append out "/bin/pencil2d")
`("QT_PLUGIN_PATH" ":" prefix (,plugin-path)))
#t))))))
(home-page "https://www.pencil2d.org")
(synopsis "Make 2D hand-drawn animations")
(description
"Pencil2D is an easy-to-use and intuitive animation and drawing tool. It
lets you create traditional hand-drawn animations (cartoons) using both bitmap
and vector graphics.")
(license license:gpl2)))

4
gnu/packages/apl.scm
View File

@ -25,8 +25,8 @@
#:use-module (guix build-system gnu)
#:use-module (gnu packages gettext)
#:use-module (gnu packages maths)
#:use-module (gnu packages databases)
#:use-module (gnu packages readline))
#:use-module (gnu packages readline)
#:use-module (gnu packages sqlite))
(define-public apl
(package

16
gnu/packages/audio.scm
View File

@ -8,7 +8,7 @@
;;; Copyright © 2016, 2017 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org>
;;; Copyright © 2016, 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2016, 2017, 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2018 okapi <okapi@firemail.cc>
;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@ -18,6 +18,7 @@
;;; Copyright © 2018 Thorsten Wilms <t_w_@freenet.de>
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2018 Brendan Tildesley <brendan.tildesley@openmailbox.org>
;;; Copyright © 2019 Pierre Langlois <pierre.langlois@gmx.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -57,7 +58,7 @@
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages curl)
#:use-module (gnu packages databases)
#:use-module (gnu packages dbm)
#:use-module (gnu packages emacs)
#:use-module (gnu packages file)
#:use-module (gnu packages flex)
@ -82,6 +83,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio) ;libsndfile, libsamplerate
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages rdf)
#:use-module (gnu packages readline)
#:use-module (gnu packages serialization)
@ -761,7 +763,7 @@ emulation (valve, tape), bit fiddling (decimator, pointer-cast), etc.")
(define-public csound
(package
(name "csound")
(version "6.11.0")
(version "6.12.0")
(source (origin
(method git-fetch)
(uri (git-reference
@ -770,7 +772,7 @@ emulation (valve, tape), bit fiddling (decimator, pointer-cast), etc.")
(file-name (git-file-name name version))
(sha256
(base32
"1hlkrnv3gghx4v382nl6v6k2k1dzm5ddk35m5g3q6pzc959726s7"))))
"0pv4s54cayvavdp6y30n3r1l5x83x9whyyd2v24y0dh224v3hbxi"))))
(build-system cmake-build-system)
(inputs
`(("alsa-lib" ,alsa-lib)
@ -2154,7 +2156,11 @@ and ALSA.")
"1rzzqa39a6llr52vjkjr0a86nc776kmr5xs52qqga8ms9697psz5"))))
(build-system gnu-build-system)
(arguments
'(#:tests? #f)) ; no check target
'(#:tests? #f ;; no check target
;; Disable xunique to prevent X hanging when starting qjackctl in
;; tiling window managers such as StumpWM or i3
;; (see https://github.com/rncbc/qjackctl/issues/13).
#:configure-flags '("--disable-xunique")))
(inputs
`(("jack" ,jack-1)
("alsa-lib" ,alsa-lib)

2
gnu/packages/avahi.scm
View File

@ -24,7 +24,7 @@
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages databases)
#:use-module (gnu packages dbm)
#:use-module (gnu packages libdaemon)
#:use-module (gnu packages linux)
#:use-module (gnu packages pkg-config)

2
gnu/packages/backup.scm
View File

@ -46,6 +46,7 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages crypto)
#:use-module (gnu packages databases)
#:use-module (gnu packages dbm)
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages ftp)
#:use-module (gnu packages glib)
@ -62,6 +63,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages rsync)
#:use-module (gnu packages ssh)
#:use-module (gnu packages tls)

1
gnu/packages/benchmark.scm
View File

@ -29,6 +29,7 @@
#:use-module (gnu packages maths)
#:use-module (gnu packages mpi)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages storage)
#:use-module (ice-9 match))

49
gnu/packages/bioconductor.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Roel Janssen <roel@gnu.org>
;;; Copyright © 2017, 2018 Roel Janssen <roel@gnu.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@ -228,6 +228,53 @@ database is exposed as a @code{TxDb} object.")
(license license:artistic2.0)))
(define-public r-biocgenerics
(package
(name "r-biocgenerics")
(version "0.28.0")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "BiocGenerics" version))
(sha256
(base32
"0cvpsrhg7sn7lpqgxvqrsagv6j7xj5rafq5xdjfd8zc4gxrs5rb8"))))
(properties
`((upstream-name . "BiocGenerics")))
(build-system r-build-system)
(home-page "https://bioconductor.org/packages/BiocGenerics")
(synopsis "S4 generic functions for Bioconductor")
(description
"This package provides S4 generic functions needed by many Bioconductor
packages.")
(license license:artistic2.0)))
(define-public r-annotate
(package
(name "r-annotate")
(version "1.60.0")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "annotate" version))
(sha256
(base32
"0p6c96lay23a67dyirgnwzm2yw22m592z780vy6p4nqwla8ha18n"))))
(build-system r-build-system)
(propagated-inputs
`(("r-annotationdbi" ,r-annotationdbi)
("r-biobase" ,r-biobase)
("r-biocgenerics" ,r-biocgenerics)
("r-dbi" ,r-dbi)
("r-rcurl" ,r-rcurl)
("r-xml" ,r-xml)
("r-xtable" ,r-xtable)))
(home-page
"https://bioconductor.org/packages/annotate")
(synopsis "Annotation for microarrays")
(description "This package provides R environments for the annotation of
microarrays.")
(license license:artistic2.0)))
(define-public r-hpar
(package
(name "r-hpar")

79
gnu/packages/bioinformatics.scm
View File

@ -98,7 +98,9 @@
#:use-module (gnu packages popt)
#:use-module (gnu packages protobuf)
#:use-module (gnu packages python)
#:use-module (gnu packages python-compression)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages readline)
#:use-module (gnu packages ruby)
#:use-module (gnu packages serialization)
@ -6338,63 +6340,6 @@ between two different types of motif instances using as much relevant
information as possible.")
(license (list license:gpl2+ license:gpl3+))))
(define-public r-vegan
(package
(name "r-vegan")
(version "2.5-3")
(source
(origin
(method url-fetch)
(uri (cran-uri "vegan" version))
(sha256
(base32
"023xznh0iy0496icpchadmp7a3rk3nj9s48fvwlvp3dssw58yp3c"))))
(build-system r-build-system)
(native-inputs
`(("gfortran" ,gfortran)))
(propagated-inputs
`(("r-cluster" ,r-cluster)
("r-knitr" ,r-knitr) ; needed for vignettes
("r-lattice" ,r-lattice)
("r-mass" ,r-mass)
("r-mgcv" ,r-mgcv)
("r-permute" ,r-permute)))
(home-page "https://cran.r-project.org/web/packages/vegan")
(synopsis "Functions for community ecology")
(description
"The vegan package provides tools for descriptive community ecology. It
has most basic functions of diversity analysis, community ordination and
dissimilarity analysis. Most of its multivariate tools can be used for other
data types as well.")
(license license:gpl2+)))
(define-public r-annotate
(package
(name "r-annotate")
(version "1.60.0")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "annotate" version))
(sha256
(base32
"0p6c96lay23a67dyirgnwzm2yw22m592z780vy6p4nqwla8ha18n"))))
(build-system r-build-system)
(propagated-inputs
`(("r-annotationdbi" ,r-annotationdbi)
("r-biobase" ,r-biobase)
("r-biocgenerics" ,r-biocgenerics)
("r-dbi" ,r-dbi)
("r-rcurl" ,r-rcurl)
("r-xml" ,r-xml)
("r-xtable" ,r-xtable)))
(home-page
"https://bioconductor.org/packages/annotate")
(synopsis "Annotation for microarrays")
(description "This package provides R environments for the annotation of
microarrays.")
(license license:artistic2.0)))
(define-public r-copynumber
(package
(name "r-copynumber")
@ -7092,26 +7037,6 @@ use multiple corrections. Visualization of data can be done either by
barplots or heatmaps.")
(license license:gpl2+)))
(define-public r-biocgenerics
(package
(name "r-biocgenerics")
(version "0.28.0")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "BiocGenerics" version))
(sha256
(base32
"0cvpsrhg7sn7lpqgxvqrsagv6j7xj5rafq5xdjfd8zc4gxrs5rb8"))))
(properties
`((upstream-name . "BiocGenerics")))
(build-system r-build-system)
(home-page "https://bioconductor.org/packages/BiocGenerics")
(synopsis "S4 generic functions for Bioconductor")
(description
"This package provides S4 generic functions needed by many Bioconductor
packages.")
(license license:artistic2.0)))
(define-public r-biocinstaller
(package
(name "r-biocinstaller")

3
gnu/packages/bittorrent.scm
View File

@ -41,7 +41,6 @@
#:use-module (gnu packages crypto)
#:use-module (gnu packages curl)
#:use-module (gnu packages cyrus-sasl)
#:use-module (gnu packages databases)
#:use-module (gnu packages file)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages glib)
@ -57,7 +56,9 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages ssh)
#:use-module (gnu packages tls)
#:use-module (gnu packages xml))

23
gnu/packages/bootloaders.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Leo Famulari <leo@famulari.name>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
@ -8,6 +8,7 @@
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 nee <nee@cock.li>
;;;
;;; This file is part of GNU Guix.
;;;
@ -55,6 +56,7 @@
#:use-module (gnu packages swig)
#:use-module (gnu packages valgrind)
#:use-module (gnu packages virtualization)
#:use-module (gnu packages xorg)
#:use-module (gnu packages web)
#:use-module (guix build-system gnu)
#:use-module (guix download)
@ -110,6 +112,12 @@
;; Make the font visible.
(copy-file (assoc-ref inputs "unifont") "unifont.bdf.gz")
(system* "gunzip" "unifont.bdf.gz")
;; Give the absolute file name of 'ckbcomp'.
(substitute* "util/grub-kbdcomp.in"
(("^ckbcomp ")
(string-append (assoc-ref inputs "console-setup")
"/bin/ckbcomp ")))
#t))
(add-before 'check 'disable-flaky-test
(lambda _
@ -134,6 +142,10 @@
;; to determine whether the root file system is RAID.
("mdadm" ,mdadm)
;; Console-setup's ckbcomp is invoked by grub-kbdcomp. It is required
;; for generating alternative keyboard layouts.
("console-setup" ,console-setup)
("freetype" ,freetype)
;; ("libusb" ,libusb)
;; ("fuse" ,fuse)
@ -717,7 +729,14 @@ board-independent tools.")))
".drv-0/source")))
;; Tests require write permissions to many of these files.
(for-each make-file-writable (find-files "tests/futility"))
#t)))
#t))
(add-after 'install 'install-devkeys
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(share (string-append out "/share/vboot-utils")))
(copy-recursively "tests/devkeys"
(string-append share "/devkeys"))
#t))))
#:test-target "runtests"))
(native-inputs
`(("pkg-config" ,pkg-config)

3
gnu/packages/calendar.scm
View File

@ -32,7 +32,6 @@
#:use-module (guix build-system python)
#:use-module (gnu packages base)
#:use-module (gnu packages check)
#:use-module (gnu packages databases)
#:use-module (gnu packages dav)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages glib)
@ -40,6 +39,8 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages time)
#:use-module (gnu packages xml)
#:use-module (srfi srfi-26))

49
gnu/packages/check.scm
View File

@ -47,13 +47,20 @@
(define-module (gnu packages check)
#:use-module (gnu packages)
#:use-module (gnu packages autotools)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages compression)
#:use-module (gnu packages linux)
#:use-module (gnu packages llvm)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
#:use-module (gnu packages golang)
#:use-module (gnu packages gtk)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages time)
#:use-module (guix utils)
#:use-module ((guix licenses) #:prefix license:)
@ -2153,3 +2160,45 @@ application \"sees\". It is meant to be loaded using the dynamic linker's
@code{LD_PRELOAD} environment variable. The @command{faketime} command
provides a simple way to achieve this.")
(license license:gpl2)))
(define-public umockdev
(package
(name "umockdev")
(version "0.11.3")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/martinpitt/umockdev/"
"releases/download/" version "/"
"umockdev-" version ".tar.xz"))
(sha256
(base32
"1in2hdan1g62wpvgjlj8mci85551ipr1964j2b9j06gm3blpihcx"))))
(build-system gnu-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'skip-broken-test
(lambda _
(substitute* "tests/test-umockdev.c"
(("/\\* sys/ in other dir")
(string-append "return; // ")))
#t)))))
(native-inputs
`(("vala" ,vala)
("python" ,python) ; for tests
("which" ,which) ; for tests
("gtk-doc" ,gtk-doc)
("pkg-config" ,pkg-config)))
(inputs
`(("glib" ,glib)
("eudev" ,eudev)
("libgudev" ,libgudev)
("gobject-introspection" ,gobject-introspection)))
(home-page "https://github.com/martinpitt/umockdev/")
(synopsis "Mock hardware devices for creating unit tests")
(description "umockdev mocks hardware devices for creating integration
tests for hardware related libraries and programs. It also provides tools to
record the properties and behaviour of particular devices, and to run a
program or test suite under a test bed with the previously recorded devices
loaded.")
(license license:lgpl2.1+)))

1
gnu/packages/chemistry.scm
View File

@ -33,6 +33,7 @@
#:use-module (gnu packages maths)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages xml)
#:use-module (guix build-system cmake)

1
gnu/packages/ci.scm
View File

@ -36,6 +36,7 @@
#:use-module (gnu packages mail)
#:use-module (gnu packages package-management)
#:use-module (gnu packages perl)
#:use-module (gnu packages perl-compression)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages tls)
#:use-module (gnu packages texinfo)

2
gnu/packages/cluster.scm
View File

@ -24,7 +24,7 @@
#:use-module (guix packages)
#:use-module (gnu packages linux)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages tls))

2
gnu/packages/cobol.scm
View File

@ -22,7 +22,7 @@
#:use-module (guix licenses)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (gnu packages databases)
#:use-module (gnu packages dbm)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages perl))

2
gnu/packages/code.scm
View File

@ -42,7 +42,6 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages compression)
#:use-module (gnu packages cpp)
#:use-module (gnu packages databases)
#:use-module (gnu packages emacs)
#:use-module (gnu packages gcc)
#:use-module (gnu packages graphviz)
@ -50,6 +49,7 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages llvm)

289
gnu/packages/compression.scm
View File

@ -47,8 +47,6 @@
#:use-module (guix git-download)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (guix build-system perl)
#:use-module (guix build-system python)
#:use-module (gnu packages)
#:use-module (gnu packages assembly)
#:use-module (gnu packages autotools)
@ -60,7 +58,6 @@
#:use-module (gnu packages file)
#:use-module (gnu packages maths)
#:use-module (gnu packages perl)
#:use-module (gnu packages perl-check)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages tls)
@ -463,44 +460,6 @@ LZO is written in ANSI C. Both the source code and the compressed data
format are designed to be portable across platforms.")
(license license:gpl2+)))
(define-public python-lzo
(package
(name "python-lzo")
(version "1.12")
(source
(origin
(method url-fetch)
(uri (pypi-uri "python-lzo" version))
(sha256
(base32
"0iakqgd51n1cd7r3lpdylm2rgbmd16y74cra9kcapwg84mlf9a4p"))))
(build-system python-build-system)
(arguments
`(#:test-target "check"
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'patch-setuppy
(lambda _
(substitute* "setup.py"
(("include_dirs.append\\(.*\\)")
(string-append "include_dirs.append('"
(assoc-ref %build-inputs "lzo")
"/include/lzo"
"')")))
#t)))))
(inputs
`(("lzo" ,lzo)))
(home-page "https://github.com/jd-boyd/python-lzo")
(synopsis "Python bindings for the LZO data compression library")
(description
"Python-LZO provides Python bindings for LZO, i.e. you can access
the LZO library from your Python scripts thereby compressing ordinary
Python strings.")
(license license:gpl2+)))
(define-public python2-lzo
(package-with-python2 python-lzo))
(define-public lzop
(package
(name "lzop")
@ -710,84 +669,6 @@ sfArk file format to the uncompressed sf2 format.")
decompression of some loosely related file formats used by Microsoft.")
(license license:lgpl2.1+)))
(define-public perl-compress-raw-bzip2
(package
(name "perl-compress-raw-bzip2")
(version "2.081")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/P/PM/PMQS/"
"Compress-Raw-Bzip2-" version ".tar.gz"))
(sha256
(base32
"081mpkjy688lg48997fqh3d7ja12vazmz02fw84495civg4vb4l6"))))
(build-system perl-build-system)
;; TODO: Use our bzip2 package.
(home-page "https://metacpan.org/release/Compress-Raw-Bzip2")
(synopsis "Low-level interface to bzip2 compression library")
(description "This module provides a Perl interface to the bzip2
compression library.")
(license license:perl-license)))
(define-public perl-compress-raw-zlib
(package
(name "perl-compress-raw-zlib")
(version "2.081")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/P/PM/PMQS/"
"Compress-Raw-Zlib-" version ".tar.gz"))
(sha256
(base32
"06rsm9ahp20xfyvd3jc69sd0k8vqysryxc6apzdbn96jbcsdwmp1"))))
(build-system perl-build-system)
(inputs
`(("zlib" ,zlib)))
(arguments
`(#:phases (modify-phases %standard-phases
(add-before
'configure 'configure-zlib
(lambda* (#:key inputs #:allow-other-keys)
(call-with-output-file "config.in"
(lambda (port)
(format port "
BUILD_ZLIB = False
INCLUDE = ~a/include
LIB = ~:*~a/lib
OLD_ZLIB = False
GZIP_OS_CODE = AUTO_DETECT"
(assoc-ref inputs "zlib"))))
#t)))))
(home-page "https://metacpan.org/release/Compress-Raw-Zlib")
(synopsis "Low-level interface to zlib compression library")
(description "This module provides a Perl interface to the zlib
compression library.")
(license license:perl-license)))
(define-public perl-io-compress
(package
(name "perl-io-compress")
(version "2.081")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/P/PM/PMQS/"
"IO-Compress-" version ".tar.gz"))
(sha256
(base32
"1na66ns1g3nni0m9q5494ym4swr21hfgpv88mw8wbj2daiswf4aj"))))
(build-system perl-build-system)
(propagated-inputs
`(("perl-compress-raw-zlib" ,perl-compress-raw-zlib) ; >=2.081
("perl-compress-raw-bzip2" ,perl-compress-raw-bzip2))) ; >=2.081
(home-page "https://metacpan.org/release/IO-Compress")
(synopsis "IO Interface to compressed files/buffers")
(description "IO-Compress provides a Perl interface to allow reading and
writing of compressed data created with the zlib and bzip2 libraries.")
(license license:perl-license)))
(define-public lz4
(package
(name "lz4")
@ -820,54 +701,6 @@ time for compression ratio.")
;; line interface programs (lz4, fullbench, fuzzer, datagen) are GPL2+.
(license (list license:bsd-2 license:gpl2+))))
(define-public python-lz4
(package
(name "python-lz4")
(version "0.10.1")
(source
(origin
(method url-fetch)
(uri (pypi-uri "lz4" version))
(sha256
(base32
"0ghv1xbaq693kgww1x9c22bplz479ls9szjsaa4ig778ls834hm0"))))
(build-system python-build-system)
(native-inputs
`(("python-nose" ,python-nose)
("python-setuptools-scm" ,python-setuptools-scm)))
(home-page "https://github.com/python-lz4/python-lz4")
(synopsis "LZ4 bindings for Python")
(description
"This package provides python bindings for the lz4 compression library
by Yann Collet. The project contains bindings for the LZ4 block format and
the LZ4 frame format.")
(license license:bsd-3)))
(define-public python2-lz4
(package-with-python2 python-lz4))
(define-public python-lzstring
(package
(name "python-lzstring")
(version "1.0.4")
(source
(origin
(method url-fetch)
(uri (pypi-uri "lzstring" version))
(sha256
(base32
"18ly9pppy2yspxzw7k1b23wk77k7m44rz2g0271bqgqrk3jn3yhs"))))
(build-system python-build-system)
(propagated-inputs
`(("python-future" ,python-future)))
(home-page "https://github.com/gkovacs/lz-string-python")
(synopsis "String compression")
(description "Lz-string is a string compressor library for Python.")
(license license:expat)))
(define-public python2-lzstring
(package-with-python2 python-lzstring))
(define-public squashfs-tools
(package
(name "squashfs-tools")
@ -1197,46 +1030,6 @@ well as bzip2.")
(license (list license:gpl3+
license:public-domain)))) ; most files in lzma/
(define-public bitshuffle
(package
(name "bitshuffle")
(version "0.3.5")
(source (origin
(method url-fetch)
(uri (pypi-uri "bitshuffle" version))
(sha256
(base32
"1823x61kyax4dc2hjmc1xraskxi1193y8lvxd03vqv029jrj8cjy"))
(modules '((guix build utils)))
(snippet
'(begin
;; Remove generated Cython files.
(delete-file "bitshuffle/h5.c")
(delete-file "bitshuffle/ext.c")
#t))))
(build-system python-build-system)
(arguments
`(#:tests? #f ; fail: https://github.com/h5py/h5py/issues/769
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'dont-build-native
(lambda _
(substitute* "setup.py"
(("'-march=native', ") ""))
#t)))))
(inputs
`(("numpy" ,python-numpy)
("h5py" ,python-h5py)
("hdf5" ,hdf5)))
(native-inputs
`(("cython" ,python-cython)))
(home-page "https://github.com/kiyo-masui/bitshuffle")
(synopsis "Filter for improving compression of typed binary data")
(description "Bitshuffle is an algorithm that rearranges typed, binary data
for improving compression, as well as a python/C package that implements this
algorithm within the Numpy framework.")
(license license:expat)))
(define-public snappy
(package
(name "snappy")
@ -1263,44 +1056,6 @@ for most inputs, but the resulting compressed files are anywhere from 20% to
100% bigger.")
(license license:asl2.0)))
(define-public bitshuffle-for-snappy
(package
(inherit bitshuffle)
(name "bitshuffle-for-snappy")
(build-system gnu-build-system)
(arguments
(substitute-keyword-arguments (package-arguments bitshuffle)
((#:tests? _ #f) #f)
((#:phases phases)
`(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(with-output-to-file "Makefile"
(lambda _
(format #t "\
libbitshuffle.so: src/bitshuffle.o src/bitshuffle_core.o src/iochain.o lz4/lz4.o
\tgcc -O3 -ffast-math -std=c99 -o $@ -shared -fPIC $^
%.o: %.c
\tgcc -O3 -ffast-math -std=c99 -fPIC -Isrc -Ilz4 -c $< -o $@
PREFIX:=~a
LIBDIR:=$(PREFIX)/lib
INCLUDEDIR:=$(PREFIX)/include
install: libbitshuffle.so
\tinstall -dm755 $(LIBDIR)
\tinstall -dm755 $(INCLUDEDIR)
\tinstall -m755 libbitshuffle.so $(LIBDIR)
\tinstall -m644 src/bitshuffle.h $(INCLUDEDIR)
\tinstall -m644 src/bitshuffle_core.h $(INCLUDEDIR)
\tinstall -m644 src/iochain.h $(INCLUDEDIR)
\tinstall -m644 lz4/lz4.h $(INCLUDEDIR)
" (assoc-ref outputs "out"))))
#t))))))
(inputs '())
(native-inputs '())))
(define-public p7zip
(package
(name "p7zip")
@ -1755,29 +1510,6 @@ recreates the stored directory structure by default.")
;; files carry the Zlib license; see "docs/copying.html" for details.
(license (list license:lgpl2.0+ license:mpl1.1))))
(define-public perl-archive-zip
(package
(name "perl-archive-zip")
(version "1.64")
(source
(origin
(method url-fetch)
(uri (string-append
"mirror://cpan/authors/id/P/PH/PHRED/Archive-Zip-"
version ".tar.gz"))
(sha256
(base32
"0zfinh8nx3rxzscp57vq3w8hihpdb0zs67vvalykcf402kr88pyy"))))
(build-system perl-build-system)
(native-inputs
;; For tests.
`(("perl-test-mockmodule" ,perl-test-mockmodule)))
(synopsis "Provides an interface to Zip archive files")
(description "The @code{Archive::Zip} module allows a Perl program to
create, manipulate, read, and write Zip archive files.")
(home-page "https://metacpan.org/release/Archive-Zip")
(license license:perl-license)))
(define-public libzip
(package
(name "libzip")
@ -1838,27 +1570,6 @@ to handle the archives, not all commands may be supported for a certain type
of archives.")
(license license:gpl2+)))
(define-public perl-archive-extract
(package
(name "perl-archive-extract")
(version "0.80")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BI/BINGOS/Archive-Extract-"
version ".tar.gz"))
(sha256
(base32
"1x15j1q6w6z8hqyqgap0lz4qbq2174wfhksy1fdd653ccbaw5jr5"))))
(build-system perl-build-system)
(home-page "https://metacpan.org/release/Archive-Extract")
(synopsis "Generic archive extracting mechanism")
(description "It allows you to extract any archive file of the type .tar,
.tar.gz, .gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma
without having to worry how it does so, or use different interfaces for each
type by using either Perl modules, or command-line tools on your system.")
(license license:perl-license)))
(define-public lunzip
(package
(name "lunzip")

1
gnu/packages/connman.scm
View File

@ -34,6 +34,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages polkit)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages readline)
#:use-module (gnu packages samba)

62
gnu/packages/cran.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016, 2017 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2017, 2018 Roel Janssen <roel@gnu.org>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Raoul Bonnal <ilpuccio.febo@gmail.com>
@ -82,6 +83,36 @@
the system clipboards.")
(license license:gpl3)))
(define-public r-vegan
(package
(name "r-vegan")
(version "2.5-3")
(source
(origin
(method url-fetch)
(uri (cran-uri "vegan" version))
(sha256
(base32
"023xznh0iy0496icpchadmp7a3rk3nj9s48fvwlvp3dssw58yp3c"))))
(build-system r-build-system)
(native-inputs
`(("gfortran" ,gfortran)))
(propagated-inputs
`(("r-cluster" ,r-cluster)
("r-knitr" ,r-knitr) ; needed for vignettes
("r-lattice" ,r-lattice)
("r-mass" ,r-mass)
("r-mgcv" ,r-mgcv)
("r-permute" ,r-permute)))
(home-page "https://cran.r-project.org/web/packages/vegan")
(synopsis "Functions for community ecology")
(description
"The vegan package provides tools for descriptive community ecology. It
has most basic functions of diversity analysis, community ordination and
dissimilarity analysis. Most of its multivariate tools can be used for other
data types as well.")
(license license:gpl2+)))
(define-public r-tidyverse
(package
(name "r-tidyverse")
@ -2503,14 +2534,14 @@ problems as well as resampling based estimators of prediction error.")
(define-public r-psych
(package
(name "r-psych")
(version "1.8.10")
(version "1.8.12")
(source
(origin
(method url-fetch)
(uri (cran-uri "psych" version))
(sha256
(base32
"0n3frgzsfmnan6cp3yyq5h6c28v5pd7q5a42pp6byaa7n7d1v478"))))
"0hvp0dkkkn0szaf5rkirr3kb8qmr4bxwl775m5wmpvn1kc25w5vf"))))
(build-system r-build-system)
(propagated-inputs
`(("r-foreign" ,r-foreign)
@ -6459,13 +6490,13 @@ and coverage methods to tune the choice of threshold.")
(define-public r-ggformula
(package
(name "r-ggformula")
(version "0.9.0")
(version "0.9.1")
(source
(origin
(method url-fetch)
(uri (cran-uri "ggformula" version))
(sha256
(base32 "1pmpdfjfbrc6kcpq70cr1kbj2qy711hw940g2aiis6l443z706kh"))))
(base32 "01ngx8qh9lhmagng6abx2ky54zi3iyj5bpxlnw59slagwv7l6icx"))))
(build-system r-build-system)
(propagated-inputs
`(("r-ggplot2" ,r-ggplot2)
@ -6504,6 +6535,29 @@ while providing the intuitive capabilities of @code{r-ggplot2}.")
used to teach mathematics, statistics, computation and modeling.")
(license license:gpl2+)))
(define-public r-raster
(package
(name "r-raster")
(version "2.8-4")
(source
(origin
(method url-fetch)
(uri (cran-uri "raster" version))
(sha256
(base32
"14pcfznxm5kdwd908axkr9v1l0hzxlrwd8kwrz0liqnfh9cx5rsa"))))
(build-system r-build-system)
(propagated-inputs
`(("r-rcpp" ,r-rcpp)
("r-sp" ,r-sp)))
(home-page "http://www.rspatial.org/")
(synopsis "Geographic data analysis and modeling")
(description
"The package implements basic and high-level functions for reading,
writing, manipulating, analyzing and modeling of gridded spatial data.
Processing of very large files is supported.")
(license license:gpl3+)))
(define-public r-mosaic
(package
(name "r-mosaic")

3
gnu/packages/crypto.scm
View File

@ -39,7 +39,6 @@
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages databases)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages image)
@ -53,10 +52,12 @@
#:use-module (gnu packages perl-check)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages readline)
#:use-module (gnu packages search)
#:use-module (gnu packages serialization)
#:use-module (gnu packages shells)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tcl)
#:use-module (gnu packages tls)
#:use-module (gnu packages xml)

1
gnu/packages/cups.scm
View File

@ -40,6 +40,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pretty-print)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages scanner)
#:use-module (gnu packages tls)

2
gnu/packages/cyrus-sasl.scm
View File

@ -20,7 +20,7 @@
(define-module (gnu packages cyrus-sasl)
#:use-module (gnu packages)
#:use-module (gnu packages databases)
#:use-module (gnu packages dbm)
#:use-module (gnu packages kerberos)
#:use-module (gnu packages tls)
#:use-module ((guix licenses) #:prefix license:)

209
gnu/packages/databases.scm
View File

@ -64,6 +64,7 @@
#:use-module (gnu packages crypto)
#:use-module (gnu packages curl)
#:use-module (gnu packages cyrus-sasl)
#:use-module (gnu packages dbm)
#:use-module (gnu packages emacs)
#:use-module (gnu packages gettext)
#:use-module (gnu packages glib)
@ -85,10 +86,12 @@
#:use-module (gnu packages popt)
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages rdf)
#:use-module (gnu packages readline)
#:use-module (gnu packages ruby)
#:use-module (gnu packages serialization)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tcl)
#:use-module (gnu packages terminals)
#:use-module (gnu packages textutils)
@ -159,28 +162,6 @@
either single machines or networked clusters.")
(license license:gpl3+)))
(define-public gdbm
(package
(name "gdbm")
(version "1.18")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/gdbm/gdbm-"
version ".tar.gz"))
(sha256
(base32
"1kimnv12bzjjhaqk4c8w2j6chdj9c6bg21lchaf7abcyfss2r0mq"))))
(arguments `(#:configure-flags '("--enable-libgdbm-compat")))
(build-system gnu-build-system)
(home-page "http://www.gnu.org.ua/software/gdbm")
(synopsis
"Hash library of database functions compatible with traditional dbm")
(description
"GDBM is a library for manipulating hashed databases. It is used to
store key/value pairs in a file in a manner similar to the Unix dbm library
and provides interfaces to the traditional file format.")
(license license:gpl3+)))
(define-public go-gopkg.in-mgo.v2
(package
(name "go-gopkg.in-mgo.v2")
@ -227,109 +208,6 @@ standard Go idioms.")
(home-page "http://labix.org/mgo")
(license license:bsd-2)))
(define-public bdb
(package
(name "bdb")
(version "6.2.32")
(source (origin
(method url-fetch)
(uri (string-append "http://download.oracle.com/berkeley-db/db-"
version ".tar.gz"))
(sha256
(base32
"1yx8wzhch5wwh016nh0kfxvknjkafv6ybkqh6nh7lxx50jqf5id9"))))
(build-system gnu-build-system)
(outputs '("out" ; programs, libraries, headers
"doc")) ; 94 MiB of HTML docs
(arguments
'(#:tests? #f ; no check target available
#:disallowed-references ("doc")
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(doc (assoc-ref outputs "doc")))
;; '--docdir' is not honored, so we need to patch.
(substitute* "dist/Makefile.in"
(("docdir[[:blank:]]*=.*")
(string-append "docdir = " doc "/share/doc/bdb")))
(invoke "./dist/configure"
(string-append "--prefix=" out)
(string-append "CONFIG_SHELL=" (which "bash"))
(string-append "SHELL=" (which "bash"))
;; Remove 7 MiB of .a files.
"--disable-static"
;; The compatibility mode is needed by some packages,
;; notably iproute2.
"--enable-compat185"
;; The following flag is needed so that the inclusion
;; of db_cxx.h into C++ files works; it leads to
;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
"--enable-cxx")))))))
(synopsis "Berkeley database")
(description
"Berkeley DB is an embeddable database allowing developers the choice of
SQL, Key/Value, XML/XQuery or Java Object storage for their data model.")
;; Starting with version 6, BDB is distributed under AGPL3. Many individual
;; files are covered by the 3-clause BSD license.
(license (list license:agpl3+ license:bsd-3))
(home-page
"http://www.oracle.com/us/products/database/berkeley-db/overview/index.html")))
(define-public bdb-5.3
(package (inherit bdb)
(name "bdb")
(version "5.3.28")
(license (license:non-copyleft "file://LICENSE"
"See LICENSE in the distribution."))
(source (origin
(method url-fetch)
(uri (string-append "http://download.oracle.com/berkeley-db/db-"
version ".tar.gz"))
(sha256
(base32
"0a1n5hbl7027fbz5lm0vp0zzfp1hmxnz14wx3zl9563h83br5ag0"))))
(arguments
`(#:tests? #f ; no check target available
#:disallowed-references ("doc")
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(doc (assoc-ref outputs "doc")))
;; '--docdir' is not honored, so we need to patch.
(substitute* "dist/Makefile.in"
(("docdir[[:blank:]]*=.*")
(string-append "docdir = " doc "/share/doc/bdb")))
(invoke "./dist/configure"
(string-append "--prefix=" out)
(string-append "CONFIG_SHELL=" (which "bash"))
(string-append "SHELL=" (which "bash"))
;; Bdb doesn't recognize aarch64 as an architecture.
,@(if (string=? "aarch64-linux" (%current-system))
'("--build=aarch64-unknown-linux-gnu")
'())
;; Remove 7 MiB of .a files.
"--disable-static"
;; The compatibility mode is needed by some packages,
;; notably iproute2.
"--enable-compat185"
;; The following flag is needed so that the inclusion
;; of db_cxx.h into C++ files works; it leads to
;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
"--enable-cxx")))))))))
(define-public es-dump-restore
(package
(name "es-dump-restore")
@ -1144,87 +1022,6 @@ browse and edit the contents, add and delete entries, all while tracking your
changes.")
(license license:gpl3+)))) ; no headers, see README.md
(define-public sqlite
(package
(name "sqlite")
(replacement sqlite-3.26.0)
(version "3.24.0")
(source (origin
(method url-fetch)
(uri (let ((numeric-version
(match (string-split version #\.)
((first-digit other-digits ...)
(string-append first-digit
(string-pad-right
(string-concatenate
(map (cut string-pad <> 2 #\0)
other-digits))
6 #\0))))))
(string-append "https://sqlite.org/2018/sqlite-autoconf-"
numeric-version ".tar.gz")))
(sha256
(base32
"0jmprv2vpggzhy7ma4ynmv1jzn3pfiwzkld0kkg6hvgvqs44xlfr"))))
(build-system gnu-build-system)
(inputs `(("readline" ,readline)))
(arguments
`(#:configure-flags
;; Add -DSQLITE_SECURE_DELETE, -DSQLITE_ENABLE_UNLOCK_NOTIFY and
;; -DSQLITE_ENABLE_DBSTAT_VTAB to CFLAGS. GNU Icecat will refuse
;; to use the system SQLite unless these options are enabled.
(list (string-append "CFLAGS=-O2 -DSQLITE_SECURE_DELETE "
"-DSQLITE_ENABLE_UNLOCK_NOTIFY "
"-DSQLITE_ENABLE_DBSTAT_VTAB"))))
(home-page "https://www.sqlite.org/")
(synopsis "The SQLite database management system")
(description
"SQLite is a software library that implements a self-contained, serverless,
zero-configuration, transactional SQL database engine. SQLite is the most
widely deployed SQL database engine in the world. The source code for SQLite
is in the public domain.")
(license license:public-domain)))
(define-public sqlite-3.26.0
(package (inherit sqlite)
(version "3.26.0")
(source (origin
(method url-fetch)
(uri (let ((numeric-version
(match (string-split version #\.)
((first-digit other-digits ...)
(string-append first-digit
(string-pad-right
(string-concatenate
(map (cut string-pad <> 2 #\0)
other-digits))
6 #\0))))))
(string-append "https://sqlite.org/2018/sqlite-autoconf-"
numeric-version ".tar.gz")))
(sha256
(base32
"0pdzszb4sp73hl36siiv3p300jvfvbcdxi2rrmkwgs6inwznmajx"))))))
;; This is used by Tracker.
(define-public sqlite-with-fts5
(package/inherit sqlite
(name "sqlite-with-fts5")
(arguments
(substitute-keyword-arguments (package-arguments sqlite)
((#:configure-flags flags)
`(cons "--enable-fts5" ,flags))))))
;; This is used by Qt.
(define-public sqlite-with-column-metadata
(package/inherit sqlite
(name "sqlite-with-column-metadata")
(arguments
(substitute-keyword-arguments (package-arguments sqlite)
((#:configure-flags flags)
`(list (string-append "CFLAGS=-O2 -DSQLITE_SECURE_DELETE "
"-DSQLITE_ENABLE_UNLOCK_NOTIFY "
"-DSQLITE_ENABLE_DBSTAT_VTAB "
"-DSQLITE_ENABLE_COLUMN_METADATA")))))))
(define-public tdb
(package
(name "tdb")

8
gnu/packages/datastructures.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016, 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2016, 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Meiyo Peng <meiyo.peng@gmail.com>
;;;
;;; This file is part of GNU Guix.
@ -123,18 +123,18 @@ in between these sequences may be different in both content and length.")
(define-public liburcu
(package
(name "liburcu")
(version "0.10.1")
(version "0.10.2")
(source (origin
(method url-fetch)
(uri (string-append "https://www.lttng.org/files/urcu/"
"userspace-rcu-" version ".tar.bz2"))
(sha256
(base32
"01pbg67qy5hcssy2yi0ckqapzfclgdq93li2rmzw4pa3wh5j42cw"))))
"1k31faqz9plx5dwxq8g1fnczxda1is4s1x4ph0gjrq3gmy6qixmk"))))
(build-system gnu-build-system)
(native-inputs
`(("perl" ,perl))) ; for tests
(home-page "http://liburcu.org/")
(home-page "https://liburcu.org/")
(synopsis "User-space RCU data synchronisation library")
(description "liburcu is a user-space @dfn{Read-Copy-Update} (RCU) data
synchronisation library. It provides read-side access that scales linearly

3
gnu/packages/dav.scm
View File

@ -25,7 +25,8 @@
#:use-module (gnu packages)
#:use-module (gnu packages check)
#:use-module (gnu packages python)
#:use-module (gnu packages python-web))
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz))
(define-public radicale
(package

159
gnu/packages/dbm.scm Normal file
View File

@ -0,0 +1,159 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 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 packages dbm)
#:use-module (gnu packages)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix utils))
;;; Commentary:
;;;
;;; This module has been separated from (gnu packages databases) to reduce the
;;; number of module references for core packages.
(define-public bdb
(package
(name "bdb")
(version "6.2.32")
(source (origin
(method url-fetch)
(uri (string-append "http://download.oracle.com/berkeley-db/db-"
version ".tar.gz"))
(sha256
(base32
"1yx8wzhch5wwh016nh0kfxvknjkafv6ybkqh6nh7lxx50jqf5id9"))))
(build-system gnu-build-system)
(outputs '("out" ; programs, libraries, headers
"doc")) ; 94 MiB of HTML docs
(arguments
'(#:tests? #f ; no check target available
#:disallowed-references ("doc")
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(doc (assoc-ref outputs "doc")))
;; '--docdir' is not honored, so we need to patch.
(substitute* "dist/Makefile.in"
(("docdir[[:blank:]]*=.*")
(string-append "docdir = " doc "/share/doc/bdb")))
(invoke "./dist/configure"
(string-append "--prefix=" out)
(string-append "CONFIG_SHELL=" (which "bash"))
(string-append "SHELL=" (which "bash"))
;; Remove 7 MiB of .a files.
"--disable-static"
;; The compatibility mode is needed by some packages,
;; notably iproute2.
"--enable-compat185"
;; The following flag is needed so that the inclusion
;; of db_cxx.h into C++ files works; it leads to
;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
"--enable-cxx")))))))
(synopsis "Berkeley database")
(description
"Berkeley DB is an embeddable database allowing developers the choice of
SQL, Key/Value, XML/XQuery or Java Object storage for their data model.")
;; Starting with version 6, BDB is distributed under AGPL3. Many individual
;; files are covered by the 3-clause BSD license.
(license (list license:agpl3+ license:bsd-3))
(home-page
"http://www.oracle.com/us/products/database/berkeley-db/overview/index.html")))
(define-public bdb-5.3
(package (inherit bdb)
(name "bdb")
(version "5.3.28")
(license (license:non-copyleft "file://LICENSE"
"See LICENSE in the distribution."))
(source (origin
(method url-fetch)
(uri (string-append "http://download.oracle.com/berkeley-db/db-"
version ".tar.gz"))
(sha256
(base32
"0a1n5hbl7027fbz5lm0vp0zzfp1hmxnz14wx3zl9563h83br5ag0"))))
(arguments
`(#:tests? #f ; no check target available
#:disallowed-references ("doc")
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(doc (assoc-ref outputs "doc")))
;; '--docdir' is not honored, so we need to patch.
(substitute* "dist/Makefile.in"
(("docdir[[:blank:]]*=.*")
(string-append "docdir = " doc "/share/doc/bdb")))
(invoke "./dist/configure"
(string-append "--prefix=" out)
(string-append "CONFIG_SHELL=" (which "bash"))
(string-append "SHELL=" (which "bash"))
;; Bdb doesn't recognize aarch64 as an architecture.
,@(if (string=? "aarch64-linux" (%current-system))
'("--build=aarch64-unknown-linux-gnu")
'())
;; Remove 7 MiB of .a files.
"--disable-static"
;; The compatibility mode is needed by some packages,
;; notably iproute2.
"--enable-compat185"
;; The following flag is needed so that the inclusion
;; of db_cxx.h into C++ files works; it leads to
;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
"--enable-cxx")))))))))
(define-public gdbm
(package
(name "gdbm")
(version "1.18")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/gdbm/gdbm-"
version ".tar.gz"))
(sha256
(base32
"1kimnv12bzjjhaqk4c8w2j6chdj9c6bg21lchaf7abcyfss2r0mq"))))
(arguments `(#:configure-flags '("--enable-libgdbm-compat")))
(build-system gnu-build-system)
(home-page "http://www.gnu.org.ua/software/gdbm")
(synopsis
"Hash library of database functions compatible with traditional dbm")
(description
"GDBM is a library for manipulating hashed databases. It is used to
store key/value pairs in a file in a manner similar to the Unix dbm library
and provides interfaces to the traditional file format.")
(license license:gpl3+)))

2
gnu/packages/dc.scm
View File

@ -23,7 +23,7 @@
#:use-module (gnu packages glib)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages databases)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tls)
#:use-module (guix packages)
#:use-module (guix download)

3
gnu/packages/debug.scm
View File

@ -285,7 +285,8 @@ down the road.")
;; patch-* phases work properly, we unpack the source first, then
;; repack before the configure phase.
(let ((make-dir (string-append "make-" (package-version gnu-make))))
`(#:configure-flags '("--with-make-tar=./make.tar.xz")
`(#:configure-flags '("--with-make-tar=./make.tar.xz"
"make_cv_sys_gnu_glob=yes")
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'unpack-make

2
gnu/packages/direct-connect.scm
View File

@ -27,7 +27,7 @@
#:use-module (gnu packages gnome)
#:use-module (gnu packages gtk)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages tls)
#:use-module (gnu packages version-control))

3
gnu/packages/disk.scm
View File

@ -38,7 +38,6 @@
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages databases)
#:use-module (gnu packages docbook)
#:use-module (gnu packages documentation)
#:use-module (gnu packages elf)
@ -55,7 +54,9 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages popt)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages readline)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages swig)
#:use-module (gnu packages vim)
#:use-module (gnu packages w3m)

3
gnu/packages/django.scm
View File

@ -32,6 +32,7 @@
#:use-module (gnu packages check)
#:use-module (gnu packages python)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages time))
(define-public python-django
@ -196,7 +197,7 @@ useful tools for testing Django applications and projects.")
(modify-phases %standard-phases
(replace 'check
(lambda _
(zero? (system* "python" "runtests.py")))))))
(invoke "python" "runtests.py"))))))
(native-inputs
`(("python-django" ,python-django)
("python-djangorestframework" ,python-djangorestframework)

1
gnu/packages/dlang.scm
View File

@ -36,6 +36,7 @@
#:use-module (gnu packages libedit)
#:use-module (gnu packages llvm)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages textutils))
(define-public rdmd

2
gnu/packages/docker.scm
View File

@ -37,6 +37,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages version-control)
#:use-module (gnu packages virtualization))
@ -517,7 +518,6 @@ provisioning etc.")
(let* ((out (assoc-ref outputs "out"))
(out-bin (string-append out "/bin")))
(chdir "build")
(install-file (readlink "docker") out-bin)
(install-file "docker" out-bin)
#t))))))
(native-inputs

2
gnu/packages/ebook.scm
View File

@ -47,8 +47,10 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages serialization)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages time)
#:use-module (gnu packages tls)
#:use-module (gnu packages web)

2
gnu/packages/education.scm
View File

@ -27,7 +27,6 @@
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages compression)
#:use-module (gnu packages databases)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages gettext)
#:use-module (gnu packages glib)
@ -40,6 +39,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages qt)
#:use-module (gnu packages sdl)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages xorg)
#:use-module (gnu packages xml)

1
gnu/packages/elf.scm
View File

@ -34,6 +34,7 @@
#:use-module (gnu packages m4)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages xml))

12869
gnu/packages/emacs-xyz.scm Normal file
View File

File diff suppressed because it is too large Load Diff

12661
gnu/packages/emacs.scm
View File

File diff suppressed because it is too large Load Diff

24
gnu/packages/emulators.scm
View File

@ -8,7 +8,7 @@
;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017, 2018 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2017, 2018, 2019 Rutger Helling <rhelling@mykolab.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -41,7 +41,6 @@
#:use-module (gnu packages backup)
#:use-module (gnu packages compression)
#:use-module (gnu packages curl)
#:use-module (gnu packages databases)
#:use-module (gnu packages fonts)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages freedesktop)
@ -65,8 +64,10 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages sdl)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages textutils)
#:use-module (gnu packages tls)
@ -237,26 +238,23 @@ turbo speed, networked multiplayer, and graphical enhancements.")
(define-public dosbox
(package
(name "dosbox")
(version "0.74.svn3947")
(version "0.74-2")
(source (origin
(method svn-fetch)
(uri (svn-reference
(url "http://svn.code.sf.net/p/dosbox/code-0/dosbox/trunk/")
(revision 3947)))
(file-name (string-append name "-" version "-checkout"))
;; Use SVN head, since the last release (2010) is incompatible
;; with GCC 4.8+ (see
;; <https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=624976>).
(method url-fetch)
(uri (string-append "https://sourceforge.net/projects/dosbox"
"/files/dosbox/" version "/dosbox-"
version ".tar.gz/download"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"1p918j6090d1nkvgq7ifvmn506zrdmyi32y7p3ms40d5ssqjg8fj"))))
"1ksp1b5szi0vy4x55rm3j1y9wq5mlslpy8llpg87rpdyjlsk0xvh"))))
(build-system gnu-build-system)
(arguments
`(#:phases (modify-phases %standard-phases
(add-after
'unpack 'autogen.sh
(lambda _
(zero? (system* "sh" "autogen.sh")))))))
(invoke "sh" "autogen.sh"))))))
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)))

1
gnu/packages/engineering.scm
View File

@ -75,6 +75,7 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages readline)
#:use-module (gnu packages swig)

1
gnu/packages/enlightenment.scm
View File

@ -55,6 +55,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages tls)
#:use-module (gnu packages video)
#:use-module (gnu packages xdisorg)

37
gnu/packages/file-systems.scm
View File

@ -35,7 +35,6 @@
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages curl)
#:use-module (gnu packages databases)
#:use-module (gnu packages datastructures)
#:use-module (gnu packages documentation)
#:use-module (gnu packages docbook)
@ -45,6 +44,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages readline)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tls)
#:use-module (gnu packages xml))
@ -248,6 +248,41 @@ All of this is accomplished without a centralized metadata server.")
"This is a file system client based on the FTP File Transfer Protocol.")
(license license:gpl2+)))
(define-public libnfs
(package
(name "libnfs")
(version "3.0.0")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/sahlberg/libnfs.git")
(commit (string-append "libnfs-" version))))
(file-name (git-file-name name version))
(sha256
(base32
"115p55y2cbs92z5lmcnjx1v29lwinpgq4sha9v1kq1vd8674h404"))))
(build-system gnu-build-system)
(home-page "https://github.com/sahlberg/libnfs")
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
("libtool" ,libtool)
("pkg-config" ,pkg-config)))
(synopsis "Client library for accessing NFS shares")
(description "LIBNFS is a client library for accessing NFS shares over a
network. LIBNFS offers three different APIs, for different use :
@enumerate
@item RAW, a fully asynchronous low level RPC library for NFS protocols. This
API provides very flexible and precise control of the RPC issued.
@item NFS ASYNC, a fully asynchronous library for high level vfs functions
@item NFS SYNC, a synchronous library for high level vfs functions.
@end enumerate\n")
(license (list license:lgpl2.1+ ; library
license:gpl3+ ; tests
license:bsd-3 ; copied nsf4 files
))))
(define-public apfs-fuse
(let ((commit "c7036a3030d128bcecefc1eabc47c039ccfdcec9")
(revision "0"))

6
gnu/packages/finance.scm
View File

@ -44,6 +44,7 @@
#:use-module (gnu packages documentation)
#:use-module (gnu packages dns)
#:use-module (gnu packages emacs)
#:use-module (gnu packages dbm)
#:use-module (gnu packages graphviz)
#:use-module (gnu packages groff)
#:use-module (gnu packages libedit)
@ -58,6 +59,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages readline)
#:use-module (gnu packages texinfo)
@ -342,7 +344,7 @@ other machines/servers. Electrum does not download the Bitcoin blockchain.")
(package
(inherit electrum)
(name "electron-cash")
(version "3.3.1")
(version "3.3.4")
(source
(origin
(method url-fetch)
@ -353,7 +355,7 @@ other machines/servers. Electrum does not download the Bitcoin blockchain.")
".tar.gz"))
(sha256
(base32
"1jdy89rfdwc2jadx3rqj5yvynpcn90cx6482ax9f1cj9gfxp9j2b"))
"0ipl6vf2n9a5n556sx2z57s7wdvg05xwjvz67kff9nmbx4s8vjyf"))
(modules '((guix build utils)))
(snippet
'(begin

1
gnu/packages/fltk.scm
View File

@ -31,6 +31,7 @@
#:use-module (gnu packages gtk) ;for "cairo"
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix git-download)

32
gnu/packages/fonts.scm
View File

@ -19,7 +19,7 @@
;;; Copyright © 2017 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Brendan Tildesley <brendan.tildesley@openmailbox.org>
;;; Copyright © 2017, 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2017, 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2017 Mohammed Sadiq <sadiq@sadiqpk.org>
;;; Copyright © 2018 Charlie Ritter <chewzerita@posteo.net>
;;; Copyright © 2018 Gabriel Hondet <gabrielhondet@gmail.com>
@ -1163,39 +1163,13 @@ itself."))))
(version "1.7")
(source
(origin
(method url-fetch)
(method url-fetch/zipbomb)
(uri (string-append "http://www.impallari.com/media/releases/dosis-"
"v" version ".zip"))
(sha256
(base32
"1qhci68f68mf87jd69vjf9qjq3wydgw1q7ivn3amjb65ls1s0c4s"))))
(build-system trivial-build-system)
(arguments
`(#:modules ((guix build utils))
#:builder (begin
(use-modules (guix build utils)
(srfi srfi-26))
(let ((PATH (string-append (assoc-ref %build-inputs
"unzip")
"/bin"))
(ttf-dir (string-append %output
"/share/fonts/truetype"))
(otf-dir (string-append %output
"/share/fonts/opentype")))
(setenv "PATH" PATH)
(invoke "unzip" (assoc-ref %build-inputs "source"))
(mkdir-p ttf-dir)
(mkdir-p otf-dir)
(for-each (lambda (ttf)
(install-file ttf ttf-dir))
(find-files "." "\\.ttf$"))
(for-each (lambda (otf)
(install-file otf otf-dir))
(find-files "." "\\.otf$"))
#t))))
(native-inputs `(("unzip" ,unzip)))
(build-system font-build-system)
(home-page "http://www.impallari.com/dosis")
(synopsis "Very simple, rounded, sans serif family")
(description

1
gnu/packages/fontutils.scm
View File

@ -36,6 +36,7 @@
#:use-module (gnu packages autotools)
#:use-module (gnu packages gettext)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages image)
#:use-module (gnu packages bison)
#:use-module (gnu packages flex)

33
gnu/packages/fpga.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2016, 2017 Theodoros Foradis <theodoros@foradis.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Amin Bandali <bandali@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -119,7 +120,7 @@ For synthesis, the compiler generates netlists in the desired format.")
(define-public yosys
(package
(name "yosys")
(version "0.7")
(version "0.8")
(source (origin
(method git-fetch)
(uri (git-reference
@ -128,7 +129,7 @@ For synthesis, the compiler generates netlists in the desired format.")
(recursive? #t))) ; for the ‘iverilog’ submodule
(sha256
(base32
"1ssrpgw0j9qlm52g1hsbb9fsww4vnwi0l7zvvky7a8w7wamddky0"))
"1qwbp8gynlklawzvpa4gdn2x0hs8zln0s3kxjqkhfcjfxffdcpvv"))
(file-name (git-file-name name version))
(modules '((guix build utils)))
(snippet
@ -211,8 +212,8 @@ For synthesis, the compiler generates netlists in the desired format.")
(license license:isc)))
(define-public icestorm
(let ((commit "12b2295c9087d94b75e374bb205ae4d76cf17e2f")
(revision "1"))
(let ((commit "c0cbae88ab47a3879aacf80d53b6a85710682a6b")
(revision "2"))
(package
(name "icestorm")
(version (string-append "0.0-" revision "-" (string-take commit 9)))
@ -224,7 +225,7 @@ For synthesis, the compiler generates netlists in the desired format.")
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"1mmzlqvap6w8n4qzv3idvy51arkgn03692ssplwncy3akjrbsd2b"))))
"0bqm0rpywm64yvbq75klpyzb1g9sdsp1kvdlyqg4hvm8jw9w8lya"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; no unit tests that don't need an FPGA exist.
@ -256,33 +257,31 @@ Includes the actual FTDI connector.")
(license license:isc))))
(define-public arachne-pnr
(let ((commit "52e69ed207342710080d85c7c639480e74a021d7")
(revision "1"))
(let ((commit "840bdfdeb38809f9f6af4d89dd7b22959b176fdd")
(revision "2"))
(package
(name "arachne-pnr")
(version (string-append "0.0-" revision "-" (string-take commit 9)))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/cseed/arachne-pnr.git")
(url "https://github.com/YosysHQ/arachne-pnr.git")
(commit commit)))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"15bdw5yxj76lxrwksp6liwmr6l1x77isf4bs50ys9rsnmiwh8c3w"))))
"1dqvjvgvsridybishv4pnigw9gypxh7r7nrqp9z9qq92v7c5rxzl"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
#:make-flags
(list (string-append "DESTDIR=" (assoc-ref %outputs "out"))
(string-append "ICEBOX=" (string-append
(assoc-ref %build-inputs "icestorm")
"/share/icebox")))
#:phases (modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs inputs #:allow-other-keys)
(substitute* '("Makefile")
(("DESTDIR = .*") (string-append "DESTDIR = "
(assoc-ref outputs "out")
"\n"))
(("ICEBOX = .*") (string-append "ICEBOX = "
(assoc-ref inputs "icestorm")
"/share/icebox\n")))
(substitute* '("./tests/fsm/generate.py"
"./tests/combinatorial/generate.py")
(("#!/usr/bin/python") "#!/usr/bin/python2"))
@ -294,7 +293,7 @@ Includes the actual FTDI connector.")
("yosys" ,yosys) ; for tests
("perl" ,perl) ; for shasum
("python-2" ,python-2))) ; for tests
(home-page "https://github.com/cseed/arachne-pnr")
(home-page "https://github.com/YosysHQ/arachne-pnr")
(synopsis "Place-and-Route tool for FPGAs")
(description "Arachne-PNR is a Place-and-Route Tool For FPGAs.")
(license license:gpl2))))

3
gnu/packages/freedesktop.scm
View File

@ -49,7 +49,6 @@
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages databases)
#:use-module (gnu packages disk)
#:use-module (gnu packages docbook)
#:use-module (gnu packages documentation)
@ -71,6 +70,8 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages polkit)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages valgrind)
#:use-module (gnu packages w3m)
#:use-module (gnu packages web)

2
gnu/packages/ftp.scm
View File

@ -29,7 +29,6 @@
#:use-module (gnu packages autotools)
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages databases)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages gettext)
#:use-module (gnu packages glib)
@ -39,6 +38,7 @@
#:use-module (gnu packages nettle)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages readline)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tls)
#:use-module (gnu packages wxwidgets)
#:use-module (gnu packages xml))

3
gnu/packages/game-development.scm
View File

@ -46,13 +46,13 @@
#:use-module (gnu packages boost)
#:use-module (gnu packages compression)
#:use-module (gnu packages curl)
#:use-module (gnu packages databases)
#:use-module (gnu packages documentation)
#:use-module (gnu packages fltk)
#:use-module (gnu packages fonts)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages fribidi)
#:use-module (gnu packages dbm)
#:use-module (gnu packages gl)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
@ -72,6 +72,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages sdl)
#:use-module (gnu packages stb)

68
gnu/packages/games.scm
View File

@ -19,7 +19,7 @@
;;; Copyright © 2016 Albin Söderqvist <albin@fripost.org>
;;; Copyright © 2016, 2017, 2018 Kei Kebreau <kkebreau@posteo.net>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016, 2017, 2018, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016 Steve Webber <webber.sl@gmail.com>
;;; Copyright © 2017 Adonay "adfeno" Felipe Nogueira <https://libreplanet.org/wiki/User:Adfeno> <adfeno@hyperbola.info>
@ -79,7 +79,6 @@
#:use-module (gnu packages curl)
#:use-module (gnu packages crypto)
#:use-module (gnu packages cyrus-sasl)
#:use-module (gnu packages databases)
#:use-module (gnu packages documentation)
#:use-module (gnu packages docbook)
#:use-module (gnu packages flex)
@ -125,11 +124,13 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages readline)
#:use-module (gnu packages shells)
#:use-module (gnu packages sdl)
#:use-module (gnu packages serialization)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages swig)
#:use-module (gnu packages tcl)
#:use-module (gnu packages texinfo)
@ -151,6 +152,7 @@
#:use-module (guix build-system go)
#:use-module (guix build-system haskell)
#:use-module (guix build-system meson)
#:use-module (guix build-system scons)
#:use-module (guix build-system python)
#:use-module (guix build-system cmake)
#:use-module (guix build-system trivial))
@ -3660,7 +3662,7 @@ throwing people around in pseudo-randomly generated buildings.")
(define-public hyperrogue
(package
(name "hyperrogue")
(version "10.5")
(version "10.5d")
;; When updating this package, be sure to update the "hyperrogue-data"
;; origin in native-inputs.
(source (origin
@ -3671,7 +3673,7 @@ throwing people around in pseudo-randomly generated buildings.")
"-src.tgz"))
(sha256
(base32
"04wk50f51xrb9vszwil4ivkfpy7xc6nw3gnp90hbna2zqi2jnvb8"))))
"1ls055v4pv2xmn2a8lav7wl370zn0wsd91q41bk0amxd168kcndy"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; no check target
@ -3748,7 +3750,7 @@ throwing people around in pseudo-randomly generated buildings.")
"-win.zip"))
(sha256
(base32
"0r6xvnr7b56iv27n8z10qmxhsz5h7w6ayhxkz3xinlvch84bk708"))))
"13n9hcvf9yv7kjghm5jhjpwq1kh94i4bgvcczky9kvdvw1y9278n"))))
("unzip" ,unzip)))
(inputs
`(("font-dejavu" ,font-dejavu)
@ -5955,3 +5957,59 @@ order. You rotate the blocks and move them across the screen to drop them in
complete lines. You score by dropping blocks fast and completing lines. As
your score gets higher, you level up and the blocks fall faster.")
(license license:gpl2+)))
(define-public endless-sky
(package
(name "endless-sky")
(version "0.9.8")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/endless-sky/endless-sky")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0i36lawypikbq8vvzfis1dn7yf6q0d2s1cllshfn7kmjb6pqfi6c"))))
(build-system scons-build-system)
(arguments
`(#:scons ,scons-python2
#:scons-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out")))
#:tests? #f ; no tests
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'patch-resource-locations
(lambda* (#:key outputs #:allow-other-keys)
(substitute* "source/Files.cpp"
(("/usr/local/")
(string-append (assoc-ref outputs "out") "/")))
#t))
(add-after 'unpack 'patch-scons
(lambda _
(substitute* "SConstruct"
;; Keep environmental variables
(("Environment\\(\\)")
"Environment(ENV = os.environ)")
;; Install into %out/bin
(("games\"") "bin\""))
#t)))))
(inputs
`(("glew" ,glew)
("libjpeg" ,libjpeg-turbo)
("libmad" ,libmad)
("libpng" ,libpng)
("openal" ,openal)
("sdl2" ,sdl2)))
(home-page "https://endless-sky.github.io/")
(synopsis "2D space trading and combat game")
(description "Endless Sky is a 2D space trading and combat game. Explore
other star systems. Earn money by trading, carrying passengers, or completing
missions. Use your earnings to buy a better ship or to upgrade the weapons and
engines on your current one. Blow up pirates. Take sides in a civil war. Or
leave human space behind and hope to find friendly aliens whose culture is more
civilized than your own.")
(license (list license:gpl3+
license:cc-by-sa3.0
license:cc-by-sa4.0
license:public-domain))))

2
gnu/packages/geo.scm
View File

@ -52,6 +52,8 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages web)
#:use-module (gnu packages webkit)
#:use-module (gnu packages wxwidgets)

1
gnu/packages/gl.scm
View File

@ -43,6 +43,7 @@
#:use-module (gnu packages llvm)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages tls)
#:use-module (gnu packages video)
#:use-module (gnu packages xdisorg)

50
gnu/packages/gnome.scm
View File

@ -75,6 +75,7 @@
#:use-module (gnu packages curl)
#:use-module (gnu packages cyrus-sasl)
#:use-module (gnu packages databases)
#:use-module (gnu packages dbm)
#:use-module (gnu packages djvu)
#:use-module (gnu packages dns)
#:use-module (gnu packages documentation)
@ -120,10 +121,12 @@
#:use-module (gnu packages python)
#:use-module (gnu packages python-crypto)
#:use-module (gnu packages python-web)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages rdesktop)
#:use-module (gnu packages scanner)
#:use-module (gnu packages selinux)
#:use-module (gnu packages slang)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages ssh)
#:use-module (gnu packages xml)
#:use-module (gnu packages gl)
@ -7377,3 +7380,50 @@ micro-pauses and rest breaks, and restricts you to your daily limit.")
hexadecimal or ASCII. It is useful for editing binary files in general.")
(home-page "https://wiki.gnome.org/Apps/Ghex")
(license license:gpl2)))
(define-public libdazzle
(package
(name "libdazzle")
(version "3.28.5")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnome/sources/" name "/"
(version-major+minor version) "/"
name "-" version ".tar.xz"))
(sha256
(base32
"08qdwv2flywnh6kibkyv0pnm67pk8xlmjh4yqx6hf13hyhkxkqgg"))))
(build-system meson-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'disable-failing-test
(lambda _
;; Disable failing test.
(substitute* "tests/meson.build"
(("test\\('test-application") "#"))
#t))
(add-before 'check 'pre-check
(lambda _
;; Tests require a running X server.
(system "Xvfb :1 &")
(setenv "DISPLAY" ":1")
#t)))))
(native-inputs
`(("glib" ,glib "bin") ; glib-compile-resources
("pkg-config" ,pkg-config)
;; For tests
("xorg-server" ,xorg-server)))
(inputs
`(("glib" ,glib)
("gobject-introspection" ,gobject-introspection)
("gtk+" ,gtk+)
("vala" ,vala)))
(home-page "https://gitlab.gnome.org/GNOME/libdazzle")
(synopsis "Companion library to GObject and Gtk+")
(description "The libdazzle library is a companion library to GObject and
Gtk+. It provides various features that the authors wish were in the
underlying library but cannot for various reasons. In most cases, they are
wildly out of scope for those libraries. In other cases, they are not quite
generic enough to work for everyone.")
(license license:gpl3+)))

12
gnu/packages/gnunet.scm
View File

@ -2,7 +2,7 @@
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2015, 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016, 2017, 2018 Nils Gillmann <ng0@n0.is>
@ -53,7 +53,7 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages databases)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages tls)
#:use-module (gnu packages video)
#:use-module (gnu packages web)
@ -189,16 +189,16 @@ authentication and support for SSL3 and TLS.")
(define-public gnurl
(package
(name "gnurl")
(version "7.62.0")
(version "7.63.0")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/gnunet/" name "-" version ".tar.Z"))
(sha256
(base32
"1n258my5q4rxv140xvb1qh6vsh42ii0i8p7f2m15szqabm89487q"))))
"021b3pdfnqywk5q07y48kxyz7g4jjg35dk3cv0ps0x50qjr4ix33"))))
(build-system gnu-build-system)
(outputs '("out"
"doc")) ; 1.5 MiB of man3 pages
"doc")) ; 1.7 MiB of man3 pages
(inputs `(("gnutls" ,gnutls/dane)
("libidn" ,libidn)
("zlib" ,zlib)))
@ -238,6 +238,8 @@ with URL syntax. While cURL supports many crypto backends, libgnurl only
supports HTTP, HTTPS and GnuTLS.")
(license (license:non-copyleft "file://COPYING"
"See COPYING in the distribution."))
(properties '((ftp-server . "ftp.gnu.org")
(ftp-directory . "/gnunet")))
(home-page "https://gnunet.org/gnurl")))
(define-public gnunet

3
gnu/packages/gnupg.scm
View File

@ -48,16 +48,17 @@
#:use-module (gnu packages perl-check)
#:use-module (gnu packages pth)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages qt)
#:use-module (gnu packages readline)
#:use-module (gnu packages compression)
#:use-module (gnu packages databases)
#:use-module (gnu packages gtk)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages security-token)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages swig)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages tls)

Some files were not shown because too many files have changed in this diff Show More