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

Merge branch 'master' into core-updates

This commit is contained in:
Ricardo Wurmus 2019-02-06 13:03:26 +01:00
parent f380f9d55e 4aeb7f34c9
commit ba88eea2b3
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
470 changed files with 107877 additions and 50432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.dir-locals.el
View File

@ -61,6 +61,7 @@
(eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
(eval . (put 'with-derivation-substitute 'scheme-indent-function 2))
(eval . (put 'with-status-report 'scheme-indent-function 1))
(eval . (put 'with-status-verbosity 'scheme-indent-function 1))
(eval . (put 'mlambda 'scheme-indent-function 1))
(eval . (put 'mlambdaq 'scheme-indent-function 1))

1
.mailmap
View File

@ -41,6 +41,7 @@ Marius Bakke <mbakke@fastmail.com> <m.bakke@warwick.ac.uk>
Mathieu Lirzin <mthl@gnu.org> <mthl@openmailbox.org>
Mathieu Lirzin <mthl@gnu.org> <mathieu.lirzin@openmailbox.org>
Mathieu Othacehe <m.othacehe@gmail.com>
Mathieu Othacehe <mathieu.othacehe@parrot.com>
Nikita Karetnikov <nikita@karetnikov.org> <nikita.karetnikov@gmail.com>
Nils Gillmann <ng0@n0.is> ng0 <ng0@n0.is>
Nils Gillmann <ng0@n0.is> Nils Gillmann <gillmann@infotropique.org>

8
Makefile.am
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 Andreas Enge <andreas@enge.fr>
# Copyright © 2015, 2017 Alex Kost <alezost@gmail.com>
# Copyright © 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
@ -64,6 +64,7 @@ MODULES = \
guix/base64.scm \
guix/ci.scm \
guix/cpio.scm \
guix/deprecation.scm \
guix/docker.scm \
guix/records.scm \
guix/pki.scm \
@ -172,7 +173,6 @@ MODULES = \
guix/build/union.scm \
guix/build/profiles.scm \
guix/build/compile.scm \
guix/build/pull.scm \
guix/build/rpath.scm \
guix/build/cvs.scm \
guix/build/svn.scm \
@ -281,6 +281,10 @@ dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
# Auxiliary files for packages.
AUX_FILES = \
gnu/packages/aux-files/emacs/guix-emacs.el \
gnu/packages/aux-files/linux-libre/4.20-arm.conf \
gnu/packages/aux-files/linux-libre/4.20-arm64.conf \
gnu/packages/aux-files/linux-libre/4.20-i686.conf \
gnu/packages/aux-files/linux-libre/4.20-x86_64.conf \
gnu/packages/aux-files/linux-libre/4.19-arm.conf \
gnu/packages/aux-files/linux-libre/4.19-arm64.conf \
gnu/packages/aux-files/linux-libre/4.19-i686.conf \

2
README
View File

@ -20,7 +20,7 @@ Guix is based on the [[https://nixos.org/nix/][Nix]] package manager.
GNU Guix currently depends on the following packages:
- [[https://gnu.org/software/guile/][GNU Guile 2.2.x or 2.0.x]], version 2.0.13 or later
- [[https://gnu.org/software/guile/][GNU Guile 2.2.x]]
- [[https://notabug.org/cwebber/guile-gcrypt][Guile-Gcrypt]] 0.1.0 or later
- [[https://www.gnu.org/software/make/][GNU Make]]
- [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled

39
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,41 @@ 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 ...
*** Add a confirmation page before formating/partitioning
** 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
...
** Display issue
*** Investigate display issue described here:
https://lists.gnu.org/archive/html/guix-devel/2019-01/msg00305.html

70
build-aux/build-self.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -114,11 +114,11 @@
(define %state-directory
;; This must match `NIX_STATE_DIR' as defined in
;; `nix/local.mk'.
(or (getenv "NIX_STATE_DIR")
(or (getenv "GUIX_STATE_DIRECTORY")
(string-append %localstatedir "/guix")))
(define %store-database-directory
(or (getenv "NIX_DB_DIR")
(or (getenv "GUIX_DATABASE_DIRECTORY")
(string-append %state-directory "/db")))
(define %config-directory
@ -293,9 +293,6 @@ interface (FFI) of Guile.")
(use-modules (ice-9 match))
(eval-when (expand load eval)
;; Don't augment '%load-path'.
(unsetenv "GUIX_PACKAGE_PATH")
;; (gnu packages …) modules are going to be looked up
;; under SOURCE. (guix config) is looked up in FRONT.
(match (command-line)
@ -312,15 +309,11 @@ interface (FFI) of Guile.")
;; Only load Guile-Gcrypt, our own modules, or those
;; of Guile.
(match %load-compiled-path
((front _ ... sys1 sys2)
(unless (string-prefix? #$guile-gcrypt front)
(set! %load-compiled-path
(list (string-append #$guile-gcrypt
"/lib/guile/"
(effective-version)
"/site-ccache")
front sys1 sys2))))))
(set! %load-compiled-path
(cons (string-append #$guile-gcrypt "/lib/guile/"
(effective-version)
"/site-ccache")
%load-compiled-path)))
(use-modules (guix store)
(guix self)
@ -334,12 +327,13 @@ interface (FFI) of Guile.")
(format (current-error-port)
"Computing Guix derivation for '~a'... "
system)
(let loop ((spin spin))
(display (string-append "\b" (car spin))
(current-error-port))
(force-output (current-error-port))
(sleep 1)
(loop (cdr spin))))
(when (isatty? (current-error-port))
(let loop ((spin spin))
(display (string-append "\b" (car spin))
(current-error-port))
(force-output (current-error-port))
(sleep 1)
(loop (cdr spin)))))
(match (command-line)
((_ source system version protocol-version)
@ -371,6 +365,19 @@ interface (FFI) of Guile.")
derivation-file-name))))))
#:module-path (list source))))
(define (call-with-clean-environment thunk)
(let ((env (environ)))
(dynamic-wind
(lambda ()
(environ '()))
thunk
(lambda ()
(environ env)))))
(define-syntax-rule (with-clean-environment exp ...)
"Evaluate EXP in a context where zero environment variables are defined."
(call-with-clean-environment (lambda () exp ...)))
;; The procedure below is our return value.
(define* (build source
#:key verbose? (version (date-version-string)) system
@ -405,14 +412,17 @@ files."
;; stdin will actually be /dev/null.
(let* ((pipe (with-input-from-port port
(lambda ()
(setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
(open-pipe* OPEN_READ
(derivation->output-path build)
source system version
(if (file-port? port)
(number->string
(logior major minor))
"none")))))
;; Make sure BUILD is not influenced by
;; $GUILE_LOAD_PATH & co.
(with-clean-environment
(setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
(open-pipe* OPEN_READ
(derivation->output-path build)
source system version
(if (file-port? port)
(number->string
(logior major minor))
"none"))))))
(str (get-string-all pipe))
(status (close-pipe pipe)))
(match str
@ -420,7 +430,7 @@ files."
(error "build program failed" (list build status)))
((? derivation-path? drv)
(mbegin %store-monad
(return (newline (current-output-port)))
(return (newline (current-error-port)))
((store-lift add-temp-root) drv)
(return (read-derivation-from-file drv))))
("#f"

55
build-aux/hydra/evaluate.scm
View File

@ -22,6 +22,8 @@
;;; arguments and outputs an sexp of the jobs on standard output.
(use-modules (guix store)
(guix git-download)
((guix build utils) #:select (with-directory-excursion))
(srfi srfi-19)
(ice-9 match)
(ice-9 pretty-print)
@ -81,11 +83,6 @@ Otherwise return THING."
;; Load FILE, a Scheme file that defines Hydra jobs.
(let ((port (current-output-port))
(real-build-things build-things))
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(primitive-load file)))
(with-store store
;; Make sure we don't resort to substitutes.
(set-build-options store
@ -104,23 +101,37 @@ Otherwise return THING."
"'build-things' arguments: ~s~%" args)
(apply real-build-things store args)))
;; Call the entry point of FILE and print the resulting job sexp.
(pretty-print
(match ((module-ref %user-module
(if (equal? cuirass? "cuirass")
'cuirass-jobs
'hydra-jobs))
store `((guix
. ((file-name . ,%top-srcdir)))))
(((names . thunks) ...)
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(force-output (current-error-port))
(cons job
(assert-valid-job job
(call-with-time-display thunk))))
names thunks)))
port))))
;; Add %TOP-SRCDIR to the store with a proper Git predicate so we work
;; from a clean checkout
(let ((source (add-to-store store "guix-source" #t
"sha256" %top-srcdir
#:select? (git-predicate %top-srcdir))))
(with-directory-excursion source
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(format (current-error-port)
"loading '~a' relative to '~a'...~%"
file source)
(primitive-load file))))
;; Call the entry point of FILE and print the resulting job sexp.
(pretty-print
(match ((module-ref %user-module
(if (equal? cuirass? "cuirass")
'cuirass-jobs
'hydra-jobs))
store `((guix
. ((file-name . ,source)))))
(((names . thunks) ...)
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(force-output (current-error-port))
(cons job
(assert-valid-job job
(call-with-time-display thunk))))
names thunks)))
port)))))
((command _ ...)
(format (current-error-port) "Usage: ~a FILE [cuirass]
Evaluate the Hydra or Cuirass jobs defined in FILE.~%"

452
build-aux/hydra/gnu-system.scm
View File

@ -23,64 +23,10 @@
;;; tool.
;;;
(use-modules (system base compile))
(eval-when (expand load eval)
;; Pre-load the compiler so we don't end up auto-compiling it.
(compile #t)
;; Use our very own Guix modules.
(set! %fresh-auto-compile #t)
;; Ignore .go files except for Guile's. This is because our checkout in the
;; store has mtime set to the epoch, and thus .go files look newer, even
;; though they may not correspond. Use 'reverse' so that /gnu/store/…-guile
;; comes before /run/current-system/profile.
(set! %load-compiled-path
(list
(dirname (dirname (search-path (reverse %load-compiled-path)
"ice-9/boot-9.go")))))
(and=> (assoc-ref (current-source-location) 'filename)
(lambda (file)
(let ((dir (canonicalize-path
(string-append (dirname file) "/../.."))))
(format (current-error-port) "prepending ~s to the load path~%"
dir)
(set! %load-path (cons dir %load-path))))))
(use-modules (guix config)
(guix store)
(guix grafts)
(guix profiles)
(guix packages)
(guix derivations)
(guix monads)
(use-modules (guix inferior) (guix channels)
(guix)
(guix ui)
((guix licenses) #:select (gpl3+))
((guix utils) #:select (%current-system))
((guix scripts system) #:select (read-operating-system))
((guix scripts pack)
#:select (lookup-compressor self-contained-tarball))
(gnu bootloader)
(gnu bootloader u-boot)
(gnu packages)
(gnu packages gcc)
(gnu packages base)
(gnu packages gawk)
(gnu packages guile)
(gnu packages gettext)
(gnu packages compression)
(gnu packages multiprecision)
(gnu packages make-bootstrap)
(gnu packages package-management)
(gnu system)
(gnu system vm)
(gnu system install)
(gnu tests)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 match))
;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
@ -88,371 +34,45 @@
(setvbuf (current-error-port) _IOLBF)
(set-current-output-port (current-error-port))
(define* (package->alist store package system
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra."
(parameterize ((%graft? #f))
`((derivation . ,(derivation-file-name
(package-derivation store package system
#:graft? #f)))
(description . ,(package-synopsis package))
(long-description . ,(package-description package))
(license . ,(package-license package))
(home-page . ,(package-home-page package))
(maintainers . ("bug-guix@gnu.org"))
(max-silent-time . ,(or (assoc-ref (package-properties package)
'max-silent-time)
3600)) ;1 hour by default
(timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000))))) ;20 hours by default
(define (package-job store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(let ((job-name (symbol-append job-name (string->symbol ".")
(string->symbol system))))
`(,job-name . ,(cut package->alist store package system))))
(define (package-cross-job store job-name package target system)
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM."
`(,(symbol-append (string->symbol target) (string->symbol ".") job-name
(string->symbol ".") (string->symbol system)) .
,(cute package->alist store package system
(lambda* (store package system #:key graft?)
(package-cross-derivation store package target system
#:graft? graft?)))))
(define %core-packages
;; Note: Don't put the '-final' package variants because (1) that's
;; implicit, and (2) they cannot be cross-built (due to the explicit input
;; chain.)
(list gcc-4.8 gcc-4.9 gcc-5 glibc binutils
gmp mpfr mpc coreutils findutils diffutils patch sed grep
gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
%bootstrap-binaries-tarball
%binutils-bootstrap-tarball
(%glibc-bootstrap-tarball)
%gcc-bootstrap-tarball
%guile-bootstrap-tarball
%bootstrap-tarballs))
(define %packages-to-cross-build
%core-packages)
(define %cross-targets
'("mips64el-linux-gnu"
"mips64el-linux-gnuabi64"
"arm-linux-gnueabihf"
"aarch64-linux-gnu"
"powerpc-linux-gnu"
"i586-pc-gnu" ;aka. GNU/Hurd
"i686-w64-mingw32"))
(define %guixsd-supported-systems
'("x86_64-linux" "i686-linux" "armhf-linux"))
(define %u-boot-systems
'("armhf-linux"))
(define (qemu-jobs store system)
"Return a list of jobs that build QEMU images for SYSTEM."
(define (->alist drv)
`((derivation . ,(derivation-file-name drv))
(description . "Stand-alone QEMU image of the GNU system")
(long-description . "This is a demo stand-alone QEMU image of the GNU
system.")
(license . ,gpl3+)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))))
(define (->job name drv)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
(define MiB
(expt 2 20))
(if (member system %guixsd-supported-systems)
(if (member system %u-boot-systems)
(list (->job 'flash-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image
(operating-system (inherit installation-os)
(bootloader (bootloader-configuration
(bootloader u-boot-bootloader)
(target #f))))
#:disk-image-size
(* 1500 MiB))))))
(list (->job 'usb-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image installation-os
#:disk-image-size
(* 1500 MiB)))))
(->job 'iso9660-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image installation-os
#:file-system-type
"iso9660"))))))
'()))
(define (system-test-jobs store system)
"Return a list of jobs for the system tests."
(define (test->thunk test)
(lambda ()
(define drv
(run-with-store store
(mbegin %store-monad
(set-current-system system)
(set-grafting #f)
(set-guile-for-build (default-guile))
(system-test-value test))))
`((derivation . ,(derivation-file-name drv))
(description . ,(format #f "GuixSD '~a' system test"
(system-test-name test)))
(long-description . ,(system-test-description test))
(license . ,gpl3+)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org")))))
(define (->job test)
(let ((name (string->symbol
(string-append "test." (system-test-name test)
"." system))))
(cons name (test->thunk test))))
(if (member system %guixsd-supported-systems)
(map ->job (all-system-tests))
'()))
(define (tarball-jobs store system)
"Return Hydra jobs to build the self-contained Guix binary tarball."
(define (->alist drv)
`((derivation . ,(derivation-file-name drv))
(description . "Stand-alone binary Guix tarball")
(long-description . "This is a tarball containing binaries of Guix and
all its dependencies, and ready to be installed on non-GuixSD distributions.")
(license . ,gpl3+)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))))
(define (->job name drv)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
;; XXX: Add a job for the stable Guix?
(list (->job 'binary-tarball
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(>>= (profile-derivation (packages->manifest (list guix)))
(lambda (profile)
(self-contained-tarball "guix-binary" profile
#:localstatedir? #t
#:compressor
(lookup-compressor "xz")))))
#:system system))))
(define job-name
;; Return the name of a package's job.
(compose string->symbol
(cut package-full-name <> "-")))
(define package->job
(let ((base-packages
(delete-duplicates
(append-map (match-lambda
((_ package _ ...)
(match (package-transitive-inputs package)
(((_ inputs _ ...) ...)
inputs))))
(%final-inputs)))))
(lambda (store package system)
"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid."
(cond ((member package base-packages)
(package-job store (symbol-append 'base. (job-name package))
package system))
((supported-package? package system)
(let ((drv (package-derivation store package system
#:graft? #f)))
(and (substitutable-derivation? drv)
(package-job store (job-name package)
package system))))
(else
#f)))))
(define (all-packages)
"Return the list of packages to build."
(define (adjust package result)
(cond ((package-replacement package)
(cons* package ;build both
(package-replacement package)
result))
((package-superseded package)
result) ;don't build it
(else
(cons package result))))
(fold-packages adjust
(fold adjust '() ;include base packages
(match (%final-inputs)
(((labels packages _ ...) ...)
packages)))
#:select? (const #t))) ;include hidden packages
(define (arguments->manifests arguments)
"Return the list of manifests extracted from ARGUMENTS."
(map (match-lambda
((input-name . relative-path)
(let* ((checkout (assq-ref arguments (string->symbol input-name)))
(base (assq-ref checkout 'file-name)))
(in-vicinity base relative-path))))
(assq-ref arguments 'manifests)))
(define (manifests->packages store manifests)
"Return the list of packages found in MANIFESTS."
(define (load-manifest manifest)
(save-module-excursion
(lambda ()
(set-current-module (make-user-module '((guix profiles) (gnu))))
(primitive-load manifest))))
(delete-duplicates!
(map manifest-entry-item
(append-map (compose manifest-entries
load-manifest)
manifests))))
;;;
;;; Hydra entry point.
;;;
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define subset
(match (assoc-ref arguments 'subset)
("core" 'core) ; only build core packages
("hello" 'hello) ; only build hello
(((? string?) (? string?) ...) 'list) ; only build selected list of packages
("manifests" 'manifests) ; only build packages in the list of manifests
(_ 'all))) ; build everything
"Return a list of jobs where each job is a NAME/THUNK pair."
(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 systems
(match (assoc-ref arguments 'systems)
(#f %hydra-supported-systems)
((lst ...) lst)
((? string? str) (call-with-input-string str read))))
(define commit
(assq-ref checkout 'revision))
(define (cross-jobs system)
(define (from-32-to-64? target)
;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
;; mips64el-linux-gnuabi64.
(and (or (string-prefix? "i686-" system)
(string-prefix? "i586-" system)
(string-prefix? "armhf-" system))
(string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
(define source
(assq-ref checkout 'file-name))
(define (same? target)
;; Return true if SYSTEM and TARGET are the same thing. This is so we
;; don't try to cross-compile to 'mips64el-linux-gnu' from
;; 'mips64el-linux'.
(or (string-contains target system)
(and (string-prefix? "armhf" system) ;armhf-linux
(string-prefix? "arm" target)))) ;arm-linux-gnueabihf
(define instance
(checkout->channel-instance source #:commit commit))
(define (pointless? target)
;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
(match system
((or "x86_64-linux" "i686-linux")
(if (string-contains target "mingw")
(not (string=? "x86_64-linux" system))
#f))
(_
;; Don't try to cross-compile from non-Intel platforms: this isn't
;; very useful and these are often brittle configurations.
#t)))
(define derivation
;; Compute the derivation of Guix for COMMIT.
(run-with-store store
(channel-instances->derivation (list instance))))
(define (either proc1 proc2 proc3)
(lambda (x)
(or (proc1 x) (proc2 x) (proc3 x))))
(show-what-to-build store (list derivation))
(build-derivations store (list derivation))
(append-map (lambda (target)
(map (lambda (package)
(package-cross-job store (job-name package)
package target system))
%packages-to-cross-build))
(remove (either from-32-to-64? same? pointless?)
%cross-targets)))
;; Open an inferior for the just-built Guix.
(let ((inferior (open-inferior (derivation->output-path derivation))))
(inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
;; Turn off grafts. Grafting is meant to happen on the user's machines.
(parameterize ((%graft? #f))
;; Return one job for each package, except bootstrap packages.
(append-map (lambda (system)
(format (current-error-port)
"evaluating for '~a' (heap size: ~a MiB)...~%"
system
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(invalidate-derivation-caches!)
(case subset
((all)
;; Build everything, including replacements.
(let ((all (all-packages))
(job (lambda (package)
(package->job store package
system))))
(append (filter-map job all)
(qemu-jobs store system)
(system-test-jobs store system)
(tarball-jobs store system)
(cross-jobs system))))
((core)
;; Build core packages only.
(append (map (lambda (package)
(package-job store (job-name package)
package system))
%core-packages)
(cross-jobs system)))
((hello)
;; Build hello package only.
(if (string=? system (%current-system))
(let ((hello (specification->package "hello")))
(list (package-job store (job-name hello) hello system)))
'()))
((list)
;; Build selected list of packages only.
(if (string=? system (%current-system))
(let* ((names (assoc-ref arguments 'subset))
(packages (map specification->package names)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages))
'()))
((manifests)
;; Build packages in the list of manifests.
(let* ((manifests (arguments->manifests arguments))
(packages (manifests->packages store manifests)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages)))
(else
(error "unknown subset" subset))))
systems)))
(map (match-lambda
((name . fields)
;; Hydra expects a thunk, so here it is.
(cons name (lambda () fields))))
(inferior-eval-with-store inferior store
`(lambda (store)
(map (match-lambda
((name . thunk)
(cons name (thunk))))
(hydra-jobs store ',arguments)))))))

7
build-aux/pre-inst-env.in
View File

@ -1,7 +1,7 @@
#!/bin/sh
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2017 Eric Bavier <bavier@cray.com>
#
# This file is part of GNU Guix.
@ -45,10 +45,9 @@ export PATH
# Daemon helpers.
NIX_ROOT_FINDER="$abs_top_builddir/nix/scripts/list-runtime-roots"
NIX_SUBSTITUTERS="$abs_top_builddir/nix/scripts/substitute"
NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts" # for 'guix-authenticate'
NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts" # for 'authenticate', etc.
export NIX_ROOT_FINDER NIX_SUBSTITUTERS NIX_LIBEXEC_DIR
export NIX_ROOT_FINDER NIX_LIBEXEC_DIR
NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload"
@BUILD_DAEMON_OFFLOAD_TRUE@export NIX_BUILD_HOOK

6
build-aux/run-system-tests.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -30,7 +30,7 @@
(define (built-derivations* drv)
(lambda (store)
(guard (c ((nix-protocol-error? c)
(guard (c ((store-protocol-error? c)
(values #f store)))
(values (build-derivations store drv) store))))
@ -64,7 +64,7 @@
(length tests))
(with-store store
(with-status-report print-build-event
(with-status-verbosity 2
(run-with-store store
(mlet* %store-monad ((drv (mapm %store-monad system-test-value tests))
(out -> (map derivation->output-path drv)))

22
build-aux/test-env.in
View File

@ -1,7 +1,7 @@
#!/bin/sh
# 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>
#
# This file is part of GNU Guix.
#
@ -51,19 +51,19 @@ then
NIX_STORE_DIR="`cd "@GUIX_TEST_ROOT@/store"; pwd -P`"
NIX_LOCALSTATE_DIR="@GUIX_TEST_ROOT@/var"
NIX_LOG_DIR="@GUIX_TEST_ROOT@/var/log/guix"
NIX_DB_DIR="@GUIX_TEST_ROOT@/db"
GUIX_LOG_DIRECTORY="@GUIX_TEST_ROOT@/var/log/guix"
GUIX_DATABASE_DIRECTORY="@GUIX_TEST_ROOT@/db"
NIX_ROOT_FINDER="@abs_top_builddir@/nix/scripts/list-runtime-roots"
# Choose a PID-dependent name to allow for parallel builds. Note
# that the directory name must be chosen so that the socket's file
# name is less than 108-char long (the size of `sun_path' in glibc).
# Currently, in Nix builds, we're at ~106 chars...
NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$"
GUIX_STATE_DIRECTORY="@GUIX_TEST_ROOT@/var/$$"
# We can't exit when we reach the limit, because perhaps the test doesn't
# actually rely on the daemon, but at least warn.
if test "`echo -n "$NIX_STATE_DIR/daemon-socket/socket" | wc -c`" -ge 108
if test "`echo -n "$GUIX_STATE_DIRECTORY/daemon-socket/socket" | wc -c`" -ge 108
then
echo "warning: exceeding socket file name limit; test may fail!" >&2
fi
@ -82,22 +82,22 @@ then
fi
# A place to store data of the substituter.
GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data"
rm -rf "$NIX_STATE_DIR/substituter-data"
mkdir -p "$NIX_STATE_DIR/substituter-data"
GUIX_BINARY_SUBSTITUTE_URL="file://$GUIX_STATE_DIRECTORY/substituter-data"
rm -rf "$GUIX_STATE_DIRECTORY/substituter-data"
mkdir -p "$GUIX_STATE_DIRECTORY/substituter-data"
# For a number of tests, we want to allow unsigned narinfos, for
# simplicity.
GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES=yes
# Place for the substituter's cache.
XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$"
XDG_CACHE_HOME="$GUIX_STATE_DIRECTORY/cache-$$"
# For the (guix import snix) tests.
NIXPKGS="@NIXPKGS@"
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \
NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \
NIX_LOCALSTATE_DIR GUIX_LOG_DIRECTORY GUIX_STATE_DIRECTORY GUIX_DATABASE_DIRECTORY \
NIX_ROOT_FINDER GUIX_BINARY_SUBSTITUTE_URL \
GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES \
GUIX_CONFIGURATION_DIRECTORY XDG_CACHE_HOME NIXPKGS
@ -109,7 +109,7 @@ then
--substitute-urls="$GUIX_BINARY_SUBSTITUTE_URL" &
daemon_pid=$!
trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT
trap "kill $daemon_pid ; rm -rf $GUIX_STATE_DIRECTORY" EXIT
# The test suite expects the 'guile-bootstrap' package to be available.
# Normally the Guile bootstrap tarball is downloaded by a fixed-output

21
configure.ac
View File

@ -93,16 +93,12 @@ m4_pattern_forbid([^GUIX_])
dnl Search for 'guile' and 'guild'. This macro defines
dnl 'GUILE_EFFECTIVE_VERSION'.
GUILE_PKG([2.2 2.0])
GUILE_PKG([2.2])
GUILE_PROGS
if test "x$GUILD" = "x"; then
AC_MSG_ERROR(['guild' binary not found; please check your guile-2.x installation.])
fi
if test "x$GUILE_EFFECTIVE_VERSION" = "x2.0"; then
PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.13])
fi
dnl Installation directories for .scm and .go files.
guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
@ -139,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])

483
doc/contributing.texi
View File

@ -23,6 +23,7 @@ choice.
* Building from Git:: The latest and greatest.
* Running Guix Before It Is Installed:: Hacker tricks.
* The Perfect Setup:: The right tools.
* Packaging Guidelines:: Growing the distribution.
* Coding Style:: Hygiene of the contributor.
* Submitting Patches:: Share your work.
@end menu
@ -170,7 +171,11 @@ The Perfect Setup to hack on Guix is basically the perfect setup used
for Guile hacking (@pxref{Using Guile in Emacs,,, guile, Guile Reference
Manual}). First, you need more than an editor, you need
@url{http://www.gnu.org/software/emacs, Emacs}, empowered by the
wonderful @url{http://nongnu.org/geiser/, Geiser}.
wonderful @url{http://nongnu.org/geiser/, Geiser}. To set that up, run:
@example
guix package -i emacs guile emacs-geiser
@end example
Geiser allows for interactive and incremental development from within
Emacs: code compilation and evaluation from within buffers, access to
@ -223,6 +228,455 @@ trigger string @code{origin...}, which can be expanded further. The
@code{...}, which also can be expanded further.
@node Packaging Guidelines
@section Packaging Guidelines
@cindex packages, creating
The GNU distribution is nascent and may well lack some of your favorite
packages. This section describes how you can help make the distribution
grow.
Free software packages are usually distributed in the form of
@dfn{source code tarballs}---typically @file{tar.gz} files that contain
all the source files. Adding a package to the distribution means
essentially two things: adding a @dfn{recipe} that describes how to
build the package, including a list of other packages required to build
it, and adding @dfn{package metadata} along with that recipe, such as a
description and licensing information.
In Guix all this information is embodied in @dfn{package definitions}.
Package definitions provide a high-level view of the package. They are
written using the syntax of the Scheme programming language; in fact,
for each package we define a variable bound to the package definition,
and export that variable from a module (@pxref{Package Modules}).
However, in-depth Scheme knowledge is @emph{not} a prerequisite for
creating packages. For more information on package definitions,
@pxref{Defining Packages}.
Once a package definition is in place, stored in a file in the Guix
source tree, it can be tested using the @command{guix build} command
(@pxref{Invoking guix build}). For example, assuming the new package is
called @code{gnew}, you may run this command from the Guix build tree
(@pxref{Running Guix Before It Is Installed}):
@example
./pre-inst-env guix build gnew --keep-failed
@end example
Using @code{--keep-failed} makes it easier to debug build failures since
it provides access to the failed build tree. Another useful
command-line option when debugging is @code{--log-file}, to access the
build log.
If the package is unknown to the @command{guix} command, it may be that
the source file contains a syntax error, or lacks a @code{define-public}
clause to export the package variable. To figure it out, you may load
the module from Guile to get more information about the actual error:
@example
./pre-inst-env guile -c '(use-modules (gnu packages gnew))'
@end example
Once your package builds correctly, please send us a patch
(@pxref{Submitting Patches}). Well, if you need help, we will be happy to
help you too. Once the patch is committed in the Guix repository, the
new package automatically gets built on the supported platforms by
@url{http://hydra.gnu.org/jobset/gnu/master, our continuous integration
system}.
@cindex substituter
Users can obtain the new package definition simply by running
@command{guix pull} (@pxref{Invoking guix pull}). When
@code{@value{SUBSTITUTE-SERVER}} is done building the package, installing the
package automatically downloads binaries from there
(@pxref{Substitutes}). The only place where human intervention is
needed is to review and apply the patch.
@menu
* Software Freedom:: What may go into the distribution.
* Package Naming:: What's in a name?
* Version Numbers:: When the name is not enough.
* Synopses and Descriptions:: Helping users find the right package.
* Python Modules:: A touch of British comedy.
* Perl Modules:: Little pearls.
* Java Packages:: Coffee break.
* Fonts:: Fond of fonts.
@end menu
@node Software Freedom
@subsection Software Freedom
@c Adapted from http://www.gnu.org/philosophy/philosophy.html.
@cindex free software
The GNU operating system has been developed so that users can have
freedom in their computing. GNU is @dfn{free software}, meaning that
users have the @url{http://www.gnu.org/philosophy/free-sw.html,four
essential freedoms}: to run the program, to study and change the program
in source code form, to redistribute exact copies, and to distribute
modified versions. Packages found in the GNU distribution provide only
software that conveys these four freedoms.
In addition, the GNU distribution follow the
@url{http://www.gnu.org/distros/free-system-distribution-guidelines.html,free
software distribution guidelines}. Among other things, these guidelines
reject non-free firmware, recommendations of non-free software, and
discuss ways to deal with trademarks and patents.
Some otherwise free upstream package sources contain a small and optional
subset that violates the above guidelines, for instance because this subset
is itself non-free code. When that happens, the offending items are removed
with appropriate patches or code snippets in the @code{origin} form of the
package (@pxref{Defining Packages}). This way, @code{guix
build --source} returns the ``freed'' source rather than the unmodified
upstream source.
@node Package Naming
@subsection Package Naming
@cindex package name
A package has actually two names associated with it:
First, there is the name of the @emph{Scheme variable}, the one following
@code{define-public}. By this name, the package can be made known in the
Scheme code, for instance as input to another package. Second, there is
the string in the @code{name} field of a package definition. This name
is used by package management commands such as
@command{guix package} and @command{guix build}.
Both are usually the same and correspond to the lowercase conversion of
the project name chosen upstream, with underscores replaced with
hyphens. For instance, GNUnet is available as @code{gnunet}, and
SDL_net as @code{sdl-net}.
We do not add @code{lib} prefixes for library packages, unless these are
already part of the official project name. But @pxref{Python
Modules} and @ref{Perl Modules} for special rules concerning modules for
the Python and Perl languages.
Font package names are handled differently, @pxref{Fonts}.
@node Version Numbers
@subsection Version Numbers
@cindex package version
We usually package only the latest version of a given free software
project. But sometimes, for instance for incompatible library versions,
two (or more) versions of the same package are needed. These require
different Scheme variable names. We use the name as defined
in @ref{Package Naming}
for the most recent version; previous versions use the same name, suffixed
by @code{-} and the smallest prefix of the version number that may
distinguish the two versions.
The name inside the package definition is the same for all versions of a
package and does not contain any version number.
For instance, the versions 2.24.20 and 3.9.12 of GTK+ may be packaged as follows:
@example
(define-public gtk+
(package
(name "gtk+")
(version "3.9.12")
...))
(define-public gtk+-2
(package
(name "gtk+")
(version "2.24.20")
...))
@end example
If we also wanted GTK+ 3.8.2, this would be packaged as
@example
(define-public gtk+-3.8
(package
(name "gtk+")
(version "3.8.2")
...))
@end example
@c See <https://lists.gnu.org/archive/html/guix-devel/2016-01/msg00425.html>,
@c for a discussion of what follows.
@cindex version number, for VCS snapshots
Occasionally, we package snapshots of upstream's version control system
(VCS) instead of formal releases. This should remain exceptional,
because it is up to upstream developers to clarify what the stable
release is. Yet, it is sometimes necessary. So, what should we put in
the @code{version} field?
Clearly, we need to make the commit identifier of the VCS snapshot
visible in the version string, but we also need to make sure that the
version string is monotonically increasing so that @command{guix package
--upgrade} can determine which version is newer. Since commit
identifiers, notably with Git, are not monotonically increasing, we add
a revision number that we increase each time we upgrade to a newer
snapshot. The resulting version string looks like this:
@example
2.0.11-3.cabba9e
^ ^ ^
| | `-- upstream commit ID
| |
| `--- Guix package revision
|
latest upstream version
@end example
It is a good idea to strip commit identifiers in the @code{version}
field to, say, 7 digits. It avoids an aesthetic annoyance (assuming
aesthetics have a role to play here) as well as problems related to OS
limits such as the maximum shebang length (127 bytes for the Linux
kernel.) It is best to use the full commit identifiers in
@code{origin}s, though, to avoid ambiguities. A typical package
definition may look like this:
@example
(define my-package
(let ((commit "c3f29bc928d5900971f65965feaae59e1272a3f7")
(revision "1")) ;Guix package revision
(package
(version (git-version "0.9" revision commit))
(source (origin
(method git-fetch)
(uri (git-reference
(url "git://example.org/my-package.git")
(commit commit)))
(sha256 (base32 "1mbikn@dots{}"))
(file-name (git-file-name name version))))
;; @dots{}
)))
@end example
@node Synopses and Descriptions
@subsection Synopses and Descriptions
@cindex package description
@cindex package synopsis
As we have seen before, each package in GNU@tie{}Guix includes a
synopsis and a description (@pxref{Defining Packages}). Synopses and
descriptions are important: They are what @command{guix package
--search} searches, and a crucial piece of information to help users
determine whether a given package suits their needs. Consequently,
packagers should pay attention to what goes into them.
Synopses must start with a capital letter and must not end with a
period. They must not start with ``a'' or ``the'', which usually does
not bring anything; for instance, prefer ``File-frobbing tool'' over ``A
tool that frobs files''. The synopsis should say what the package
is---e.g., ``Core GNU utilities (file, text, shell)''---or what it is
used for---e.g., the synopsis for GNU@tie{}grep is ``Print lines
matching a pattern''.
Keep in mind that the synopsis must be meaningful for a very wide
audience. For example, ``Manipulate alignments in the SAM format''
might make sense for a seasoned bioinformatics researcher, but might be
fairly unhelpful or even misleading to a non-specialized audience. It
is a good idea to come up with a synopsis that gives an idea of the
application domain of the package. In this example, this might give
something like ``Manipulate nucleotide sequence alignments'', which
hopefully gives the user a better idea of whether this is what they are
looking for.
Descriptions should take between five and ten lines. Use full
sentences, and avoid using acronyms without first introducing them.
Please avoid marketing phrases such as ``world-leading'',
``industrial-strength'', and ``next-generation'', and avoid superlatives
like ``the most advanced''---they are not helpful to users looking for a
package and may even sound suspicious. Instead, try to be factual,
mentioning use cases and features.
@cindex Texinfo markup, in package descriptions
Descriptions can include Texinfo markup, which is useful to introduce
ornaments such as @code{@@code} or @code{@@dfn}, bullet lists, or
hyperlinks (@pxref{Overview,,, texinfo, GNU Texinfo}). However you
should be careful when using some characters for example @samp{@@} and
curly braces which are the basic special characters in Texinfo
(@pxref{Special Characters,,, texinfo, GNU Texinfo}). User interfaces
such as @command{guix package --show} take care of rendering it
appropriately.
Synopses and descriptions are translated by volunteers
@uref{http://translationproject.org/domain/guix-packages.html, at the
Translation Project} so that as many users as possible can read them in
their native language. User interfaces search them and display them in
the language specified by the current locale.
To allow @command{xgettext} to extract them as translatable strings,
synopses and descriptions @emph{must be literal strings}. This means
that you cannot use @code{string-append} or @code{format} to construct
these strings:
@lisp
(package
;; @dots{}
(synopsis "This is translatable")
(description (string-append "This is " "*not*" " translatable.")))
@end lisp
Translation is a lot of work so, as a packager, please pay even more
attention to your synopses and descriptions as every change may entail
additional work for translators. In order to help them, it is possible
to make recommendations or instructions visible to them by inserting
special comments like this (@pxref{xgettext Invocation,,, gettext, GNU
Gettext}):
@example
;; TRANSLATORS: "X11 resize-and-rotate" should not be translated.
(description "ARandR is designed to provide a simple visual front end
for the X11 resize-and-rotate (RandR) extension. @dots{}")
@end example
@node Python Modules
@subsection Python Modules
@cindex python
We currently package Python 2 and Python 3, under the Scheme variable names
@code{python-2} and @code{python} as explained in @ref{Version Numbers}.
To avoid confusion and naming clashes with other programming languages, it
seems desirable that the name of a package for a Python module contains
the word @code{python}.
Some modules are compatible with only one version of Python, others with both.
If the package Foo compiles only with Python 3, we name it
@code{python-foo}; if it compiles only with Python 2, we name it
@code{python2-foo}. If it is compatible with both versions, we create two
packages with the corresponding names.
If a project already contains the word @code{python}, we drop this;
for instance, the module python-dateutil is packaged under the names
@code{python-dateutil} and @code{python2-dateutil}. If the project name
starts with @code{py} (e.g.@: @code{pytz}), we keep it and prefix it as
described above.
@subsubsection Specifying Dependencies
@cindex inputs, for Python packages
Dependency information for Python packages is usually available in the
package source tree, with varying degrees of accuracy: in the
@file{setup.py} file, in @file{requirements.txt}, or in @file{tox.ini}.
Your mission, when writing a recipe for a Python package, is to map
these dependencies to the appropriate type of ``input'' (@pxref{package
Reference, inputs}). Although the @code{pypi} importer normally does a
good job (@pxref{Invoking guix import}), you may want to check the
following check list to determine which dependency goes where.
@itemize
@item
We currently package Python 2 with @code{setuptools} and @code{pip}
installed like Python 3.4 has per default. Thus you don't need to
specify either of these as an input. @command{guix lint} will warn you
if you do.
@item
Python dependencies required at run time go into
@code{propagated-inputs}. They are typically defined with the
@code{install_requires} keyword in @file{setup.py}, or in the
@file{requirements.txt} file.
@item
Python packages required only at build time---e.g., those listed with
the @code{setup_requires} keyword in @file{setup.py}---or only for
testing---e.g., those in @code{tests_require}---go into
@code{native-inputs}. The rationale is that (1) they do not need to be
propagated because they are not needed at run time, and (2) in a
cross-compilation context, it's the ``native'' input that we'd want.
Examples are the @code{pytest}, @code{mock}, and @code{nose} test
frameworks. Of course if any of these packages is also required at
run-time, it needs to go to @code{propagated-inputs}.
@item
Anything that does not fall in the previous categories goes to
@code{inputs}, for example programs or C libraries required for building
Python packages containing C extensions.
@item
If a Python package has optional dependencies (@code{extras_require}),
it is up to you to decide whether to add them or not, based on their
usefulness/overhead ratio (@pxref{Submitting Patches, @command{guix
size}}).
@end itemize
@node Perl Modules
@subsection Perl Modules
@cindex perl
Perl programs standing for themselves are named as any other package,
using the lowercase upstream name.
For Perl packages containing a single class, we use the lowercase class name,
replace all occurrences of @code{::} by dashes and prepend the prefix
@code{perl-}.
So the class @code{XML::Parser} becomes @code{perl-xml-parser}.
Modules containing several classes keep their lowercase upstream name and
are also prepended by @code{perl-}. Such modules tend to have the word
@code{perl} somewhere in their name, which gets dropped in favor of the
prefix. For instance, @code{libwww-perl} becomes @code{perl-libwww}.
@node Java Packages
@subsection Java Packages
@cindex java
Java programs standing for themselves are named as any other package,
using the lowercase upstream name.
To avoid confusion and naming clashes with other programming languages,
it is desirable that the name of a package for a Java package is
prefixed with @code{java-}. If a project already contains the word
@code{java}, we drop this; for instance, the package @code{ngsjava} is
packaged under the name @code{java-ngs}.
For Java packages containing a single class or a small class hierarchy,
we use the lowercase class name, replace all occurrences of @code{.} by
dashes and prepend the prefix @code{java-}. So the class
@code{apache.commons.cli} becomes package
@code{java-apache-commons-cli}.
@node Fonts
@subsection Fonts
@cindex fonts
For fonts that are in general not installed by a user for typesetting
purposes, or that are distributed as part of a larger software package,
we rely on the general packaging rules for software; for instance, this
applies to the fonts delivered as part of the X.Org system or fonts that
are part of TeX Live.
To make it easier for a user to search for fonts, names for other packages
containing only fonts are constructed as follows, independently of the
upstream package name.
The name of a package containing only one font family starts with
@code{font-}; it is followed by the foundry name and a dash @code{-}
if the foundry is known, and the font family name, in which spaces are
replaced by dashes (and as usual, all upper case letters are transformed
to lower case).
For example, the Gentium font family by SIL is packaged under the name
@code{font-sil-gentium}.
For a package containing several font families, the name of the collection
is used in the place of the font family name.
For instance, the Liberation fonts consist of three families,
Liberation Sans, Liberation Serif and Liberation Mono.
These could be packaged separately under the names
@code{font-liberation-sans} and so on; but as they are distributed together
under a common name, we prefer to package them together as
@code{font-liberation}.
In the case where several formats of the same font family or font collection
are packaged separately, a short form of the format, prepended by a dash,
is added to the package name. We use @code{-ttf} for TrueType fonts,
@code{-otf} for OpenType fonts and @code{-type1} for PostScript Type 1
fonts.
@node Coding Style
@section Coding Style
@ -363,6 +817,33 @@ name of the new or modified package, and fix any errors it reports
Make sure the package builds on your platform, using @code{guix build
@var{package}}.
@item
We recommend you also try building the package on other supported
platforms. As you may not have access to actual hardware platforms, we
recommend using the @code{qemu-binfmt-service-type} to emulate them. In
order to enable it, add the following service to the list of services in
your @code{operating-system} configuration:
@example
(service qemu-binfmt-service-type
(qemu-binfmt-configuration
(platforms (lookup-qemu-platforms "arm" "aarch64" "ppc" "mips64el"))
(guix-support? #t)))
@end example
Then reconfigure your system.
You can then build packages for different platforms by specifying the
@code{--system} option. For example, to build the "hello" package for
the armhf, aarch64, powerpc, or mips64 architectures, you would run the
following commands, respectively:
@example
guix build --system=armhf-linux --rounds=2 hello
guix build --system=aarch64-linux --rounds=2 hello
guix build --system=powerpc-linux --rounds=2 hello
guix build --system=mips64el-linux --rounds=2 hello
@end example
@item
@cindex bundling
Make sure the package does not use bundled copies of software already

2739
doc/guix.texi
View File

File diff suppressed because it is too large Load Diff

9
etc/guix-install.sh
View File

@ -1,4 +1,4 @@
#!/bin/bash
#!/bin/sh
# GNU Guix --- Functional package management for GNU
# Copyright © 2017 sharlatan <sharlatanus@gmail.com>
# Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
@ -19,6 +19,13 @@
# You should have received a copy of the GNU General Public License
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
# We require Bash but for portability we'd rather not use /bin/bash or
# /usr/bin/env in the shebang, hence this hack.
if [ "x$BASH_VERSION" = "x" ]
then
exec bash "$0" "$@"
fi
set -e
[ "$UID" -eq 0 ] || { echo "This script must be run as root."; exit 1; }

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

28
gnu/build/linux-modules.scm
View File

@ -33,6 +33,7 @@
ensure-dot-ko
module-aliases
module-dependencies
module-soft-dependencies
normalize-module-name
file-name->module-name
find-module-file
@ -100,6 +101,33 @@ contains module names, not actual file names."
(('depends . what)
(string-tokenize what %not-comma)))))
(define not-softdep-whitespace
(char-set-complement (char-set #\space #\tab)))
(define (module-soft-dependencies file)
"Return a list of (cons section soft-dependency) of module FILE."
;; TEXT: "pre: baz blubb foo post: bax bar"
(define (parse-softdep text)
(let loop ((value '())
(tokens (string-tokenize text not-softdep-whitespace))
(section #f))
(match tokens
((token rest ...)
(if (string=? (string-take-right token 1) ":") ; section
(loop value rest (string-trim-both (string-drop-right token 1)))
(loop (cons (cons section token) value) rest section)))
(()
value))))
;; Note: Multiple 'softdep sections are allowed.
(let ((info (modinfo-section-contents file)))
(concatenate
(filter-map (match-lambda
(('softdep . value)
(parse-softdep value))
(_ #f))
(modinfo-section-contents file)))))
(define (module-aliases file)
"Return the list of aliases of module FILE."
(let ((info (modinfo-section-contents file)))

505
gnu/ci.scm Normal file
View File

@ -0,0 +1,505 @@
;;; GNU Guix --- Functional package management for GNU
;;; 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>
;;;
;;; 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 ci)
#:use-module (guix config)
#:use-module (guix store)
#: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)
#:select (gpl3+ license? license-name))
#:use-module ((guix utils) #:select (%current-system))
#:use-module ((guix scripts system) #:select (read-operating-system))
#:use-module ((guix scripts pack)
#:select (lookup-compressor self-contained-tarball))
#:use-module (gnu bootloader)
#:use-module (gnu bootloader u-boot)
#:use-module (gnu packages)
#:use-module (gnu packages gcc)
#:use-module (gnu packages base)
#:use-module (gnu packages gawk)
#:use-module (gnu packages guile)
#:use-module (gnu packages gettext)
#:use-module (gnu packages compression)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages make-bootstrap)
#:use-module (gnu packages package-management)
#:use-module (gnu system)
#:use-module (gnu system vm)
#:use-module (gnu system install)
#:use-module (gnu tests)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (hydra-jobs))
;;; Commentary:
;;;
;;; This file defines build jobs for the Hydra and Cuirass continuation
;;; integration tools.
;;;
;;; Code:
(define* (package->alist store package system
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra."
(parameterize ((%graft? #f))
`((derivation . ,(derivation-file-name
(package-derivation store package system
#:graft? #f)))
(description . ,(package-synopsis package))
(long-description . ,(package-description package))
;; XXX: Hydra ignores licenses that are not a <license> structure or a
;; list thereof.
(license . ,(let loop ((license (package-license package)))
(match license
((? license?)
(license-name license))
((lst ...)
(map loop license)))))
(home-page . ,(package-home-page package))
(maintainers . ("bug-guix@gnu.org"))
(max-silent-time . ,(or (assoc-ref (package-properties package)
'max-silent-time)
3600)) ;1 hour by default
(timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000))))) ;20 hours by default
(define (package-job store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(let ((job-name (symbol-append job-name (string->symbol ".")
(string->symbol system))))
`(,job-name . ,(cut package->alist store package system))))
(define (package-cross-job store job-name package target system)
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM."
`(,(symbol-append (string->symbol target) (string->symbol ".") job-name
(string->symbol ".") (string->symbol system)) .
,(cute package->alist store package system
(lambda* (store package system #:key graft?)
(package-cross-derivation store package target system
#:graft? graft?)))))
(define %core-packages
;; Note: Don't put the '-final' package variants because (1) that's
;; implicit, and (2) they cannot be cross-built (due to the explicit input
;; chain.)
(list gcc-4.8 gcc-4.9 gcc-5 glibc binutils
gmp mpfr mpc coreutils findutils diffutils patch sed grep
gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
%bootstrap-binaries-tarball
%binutils-bootstrap-tarball
(%glibc-bootstrap-tarball)
%gcc-bootstrap-tarball
%guile-bootstrap-tarball
%bootstrap-tarballs))
(define %packages-to-cross-build
%core-packages)
(define %cross-targets
'("mips64el-linux-gnu"
"mips64el-linux-gnuabi64"
"arm-linux-gnueabihf"
"aarch64-linux-gnu"
"powerpc-linux-gnu"
"i586-pc-gnu" ;aka. GNU/Hurd
"i686-w64-mingw32"))
(define %guixsd-supported-systems
'("x86_64-linux" "i686-linux" "armhf-linux"))
(define %u-boot-systems
'("armhf-linux"))
(define (qemu-jobs store system)
"Return a list of jobs that build QEMU images for SYSTEM."
(define (->alist drv)
`((derivation . ,(derivation-file-name drv))
(description . "Stand-alone QEMU image of the GNU system")
(long-description . "This is a demo stand-alone QEMU image of the GNU
system.")
(license . ,(license-name gpl3+))
(max-silent-time . 600)
(timeout . 3600)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))))
(define (->job name drv)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
(define MiB
(expt 2 20))
(if (member system %guixsd-supported-systems)
(if (member system %u-boot-systems)
(list (->job 'flash-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image
(operating-system (inherit installation-os)
(bootloader (bootloader-configuration
(bootloader u-boot-bootloader)
(target #f))))
#:disk-image-size
(* 1500 MiB))))))
(list (->job 'usb-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image installation-os
#:disk-image-size
(* 1500 MiB)))))
(->job 'iso9660-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image installation-os
#:file-system-type
"iso9660"))))))
'()))
(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
(run-with-store store
(mbegin %store-monad
(set-current-system system)
(set-grafting #f)
(set-guile-for-build (default-guile))
(system-test-value test))))
`((derivation . ,(derivation-file-name drv))
(description . ,(format #f "GuixSD '~a' system test"
(system-test-name test)))
(long-description . ,(system-test-description test))
(license . ,(license-name gpl3+))
(max-silent-time . 600)
(timeout . 3600)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org")))))
(define (->job test)
(let ((name (string->symbol
(string-append "test." (system-test-name test)
"." system))))
(cons name (test->thunk test))))
(if (and (member system %guixsd-supported-systems)
;; XXX: Our build farm has too few ARMv7 machines and they are very
;; slow, so skip system tests there.
(not (string=? system "armhf-linux")))
;; 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)
"Return Hydra jobs to build the self-contained Guix binary tarball."
(define (->alist drv)
`((derivation . ,(derivation-file-name drv))
(description . "Stand-alone binary Guix tarball")
(long-description . "This is a tarball containing binaries of Guix and
all its dependencies, and ready to be installed on non-GuixSD distributions.")
(license . ,(license-name gpl3+))
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))))
(define (->job name drv)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
;; XXX: Add a job for the stable Guix?
(list (->job 'binary-tarball
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(>>= (profile-derivation (packages->manifest (list guix)))
(lambda (profile)
(self-contained-tarball "guix-binary" profile
#:localstatedir? #t
#:compressor
(lookup-compressor "xz")))))
#:system system))))
(define job-name
;; Return the name of a package's job.
(compose string->symbol
(cut package-full-name <> "-")))
(define package->job
(let ((base-packages
(delete-duplicates
(append-map (match-lambda
((_ package _ ...)
(match (package-transitive-inputs package)
(((_ inputs _ ...) ...)
inputs))))
(%final-inputs)))))
(lambda (store package system)
"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid."
(cond ((member package base-packages)
(package-job store (symbol-append 'base. (job-name package))
package system))
((supported-package? package system)
(let ((drv (package-derivation store package system
#:graft? #f)))
(and (substitutable-derivation? drv)
(package-job store (job-name package)
package system))))
(else
#f)))))
(define (all-packages)
"Return the list of packages to build."
(define (adjust package result)
(cond ((package-replacement package)
(cons* package ;build both
(package-replacement package)
result))
((package-superseded package)
result) ;don't build it
(else
(cons package result))))
(fold-packages adjust
(fold adjust '() ;include base packages
(match (%final-inputs)
(((labels packages _ ...) ...)
packages)))
#:select? (const #t))) ;include hidden packages
(define (arguments->manifests arguments)
"Return the list of manifests extracted from ARGUMENTS."
(map (match-lambda
((input-name . relative-path)
(let* ((checkout (assq-ref arguments (string->symbol input-name)))
(base (assq-ref checkout 'file-name)))
(in-vicinity base relative-path))))
(assq-ref arguments 'manifests)))
(define (manifests->packages store manifests)
"Return the list of packages found in MANIFESTS."
(define (load-manifest manifest)
(save-module-excursion
(lambda ()
(set-current-module (make-user-module '((guix profiles) (gnu))))
(primitive-load manifest))))
(delete-duplicates!
(map manifest-entry-item
(append-map (compose manifest-entries
load-manifest)
manifests))))
;;;
;;; Hydra entry point.
;;;
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define subset
(match (assoc-ref arguments 'subset)
("core" 'core) ; only build core packages
("hello" 'hello) ; only build hello
(((? string?) (? string?) ...) 'list) ; only build selected list of packages
("manifests" 'manifests) ; only build packages in the list of manifests
(_ 'all))) ; build everything
(define systems
(match (assoc-ref arguments 'systems)
(#f %hydra-supported-systems)
((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
;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
;; mips64el-linux-gnuabi64.
(and (or (string-prefix? "i686-" system)
(string-prefix? "i586-" system)
(string-prefix? "armhf-" system))
(string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
(define (same? target)
;; Return true if SYSTEM and TARGET are the same thing. This is so we
;; don't try to cross-compile to 'mips64el-linux-gnu' from
;; 'mips64el-linux'.
(or (string-contains target system)
(and (string-prefix? "armhf" system) ;armhf-linux
(string-prefix? "arm" target)))) ;arm-linux-gnueabihf
(define (pointless? target)
;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
(match system
((or "x86_64-linux" "i686-linux")
(if (string-contains target "mingw")
(not (string=? "x86_64-linux" system))
#f))
(_
;; Don't try to cross-compile from non-Intel platforms: this isn't
;; very useful and these are often brittle configurations.
#t)))
(define (either proc1 proc2 proc3)
(lambda (x)
(or (proc1 x) (proc2 x) (proc3 x))))
(append-map (lambda (target)
(map (lambda (package)
(package-cross-job store (job-name package)
package target system))
%packages-to-cross-build))
(remove (either from-32-to-64? same? pointless?)
%cross-targets)))
;; Turn off grafts. Grafting is meant to happen on the user's machines.
(parameterize ((%graft? #f))
;; Return one job for each package, except bootstrap packages.
(append-map (lambda (system)
(format (current-error-port)
"evaluating for '~a' (heap size: ~a MiB)...~%"
system
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(invalidate-derivation-caches!)
(case subset
((all)
;; Build everything, including replacements.
(let ((all (all-packages))
(job (lambda (package)
(package->job store package
system))))
(append (filter-map job all)
(qemu-jobs store system)
(system-test-jobs store system
#:source source
#:commit commit)
(tarball-jobs store system)
(cross-jobs system))))
((core)
;; Build core packages only.
(append (map (lambda (package)
(package-job store (job-name package)
package system))
%core-packages)
(cross-jobs system)))
((hello)
;; Build hello package only.
(if (string=? system (%current-system))
(let ((hello (specification->package "hello")))
(list (package-job store (job-name hello) hello system)))
'()))
((list)
;; Build selected list of packages only.
(if (string=? system (%current-system))
(let* ((names (assoc-ref arguments 'subset))
(packages (map specification->package names)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages))
'()))
((manifests)
;; Build packages in the list of manifests.
(let* ((manifests (arguments->manifests arguments))
(packages (manifests->packages store manifests)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages)))
(else
(error "unknown subset" subset))))
systems)))

359
gnu/installer.scm Normal file
View File

@ -0,0 +1,359 @@
;;; 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)
#:use-module (gnu packages guile-xyz)
#: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))))

134
gnu/local.mk
View File

@ -1,15 +1,15 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Andreas Enge <andreas@enge.fr>
# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Andreas Enge <andreas@enge.fr>
# Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
# Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Mark H Weaver <mhw@netris.org>
# Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org>
# Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
# Copyright © 2016, 2017, 2018 Kei Kebreau <kkebreau@posteo.net>
# Copyright © 2016, 2017 Rene Saavedra <rennes@openmailbox.org>
# Copyright © 2016 Adonay "adfeno" Felipe Nogueira <https://libreplanet.org/wiki/User:Adfeno> <adfeno@openmailbox.org>
# Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
# Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
# Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
# Copyright © 2016, 2017, 2018 Alex Vong <alexvong1995@gmail.com>
# Copyright © 2016, 2017, 2018, 2019 Alex Vong <alexvong1995@gmail.com>
# Copyright © 2016, 2017 Efraim Flashner <efraim@flashner.co.il>
# Copyright © 2016, 2017 Jan Nieuwenhuizen <janneke@gnu.org>
# Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
@ -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 \
@ -109,10 +110,10 @@ GNU_SYSTEM_MODULES = \
%D%/packages/commencement.scm \
%D%/packages/compression.scm \
%D%/packages/compton.scm \
%D%/packages/conkeror.scm \
%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 \
@ -127,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 \
@ -150,11 +152,13 @@ GNU_SYSTEM_MODULES = \
%D%/packages/ebook.scm \
%D%/packages/ed.scm \
%D%/packages/education.scm \
%D%/packages/efi.scm \
%D%/packages/electronics.scm \
%D%/packages/elf.scm \
%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 \
@ -217,6 +221,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/gtk.scm \
%D%/packages/guile.scm \
%D%/packages/guile-wm.scm \
%D%/packages/guile-xyz.scm \
%D%/packages/gv.scm \
%D%/packages/gxmessage.scm \
%D%/packages/hardware.scm \
@ -242,9 +247,11 @@ GNU_SYSTEM_MODULES = \
%D%/packages/irc.scm \
%D%/packages/iso-codes.scm \
%D%/packages/java.scm \
%D%/packages/java-compression.scm \
%D%/packages/javascript.scm \
%D%/packages/jemalloc.scm \
%D%/packages/jrnl.scm \
%D%/packages/jose.scm \
%D%/packages/julia.scm \
%D%/packages/kde.scm \
%D%/packages/kde-frameworks.scm \
@ -347,6 +354,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 \
@ -365,8 +373,11 @@ GNU_SYSTEM_MODULES = \
%D%/packages/pure.scm \
%D%/packages/pv.scm \
%D%/packages/python.scm \
%D%/packages/python-check.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 \
@ -385,6 +396,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/rush.scm \
%D%/packages/rust.scm \
%D%/packages/samba.scm \
%D%/packages/sagemath.scm \
%D%/packages/sawfish.scm \
%D%/packages/scanner.scm \
%D%/packages/scheme.scm \
@ -409,6 +421,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 \
@ -483,6 +496,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/desktop.scm \
%D%/services/dict.scm \
%D%/services/dns.scm \
%D%/services/docker.scm \
%D%/services/authentication.scm \
%D%/services/games.scm \
%D%/services/kerberos.scm \
@ -541,6 +555,7 @@ GNU_SYSTEM_MODULES = \
%D%/tests/databases.scm \
%D%/tests/desktop.scm \
%D%/tests/dict.scm \
%D%/tests/docker.scm \
%D%/tests/monitoring.scm \
%D%/tests/nfs.scm \
%D%/tests/install.scm \
@ -554,6 +569,47 @@ GNU_SYSTEM_MODULES = \
%D%/tests/virtualization.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%/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/user.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 += \
%D%/build/shepherd.scm \
@ -578,12 +634,13 @@ dist_patch_DATA = \
%D%/packages/patches/aegisub-icu59-include-unistr.patch \
%D%/packages/patches/aegisub-boost68.patch \
%D%/packages/patches/agg-am_c_prototype.patch \
%D%/packages/patches/allegro-fix-compilation-mesa-18.2.5-and-later.patch \
%D%/packages/patches/amule-crypto-6.patch \
%D%/packages/patches/antiword-CVE-2014-8123.patch \
%D%/packages/patches/antlr3-3_1-fix-java8-compilation.patch \
%D%/packages/patches/antlr3-3_3-fix-java8-compilation.patch \
%D%/packages/patches/ao-cad-aarch64-support.patch \
%D%/packages/patches/apr-skip-getservbyname-test.patch \
%D%/packages/patches/aria2-CVE-2019-3500.patch \
%D%/packages/patches/aspell-default-dict-dir.patch \
%D%/packages/patches/ath9k-htc-firmware-binutils.patch \
%D%/packages/patches/ath9k-htc-firmware-gcc.patch \
@ -603,9 +660,9 @@ dist_patch_DATA = \
%D%/packages/patches/beets-python-3.7-fix.patch \
%D%/packages/patches/beignet-correct-file-names.patch \
%D%/packages/patches/binutils-boot-2.20.1a.patch \
%D%/packages/patches/biber-fix-encoding-write.patch \
%D%/packages/patches/binutils-loongson-workaround.patch \
%D%/packages/patches/blast+-fix-makefile.patch \
%D%/packages/patches/blender-newer-ffmpeg.patch \
%D%/packages/patches/boost-fix-icu-build.patch \
%D%/packages/patches/byobu-writable-status.patch \
%D%/packages/patches/cairo-CVE-2016-9082.patch \
@ -638,6 +695,8 @@ dist_patch_DATA = \
%D%/packages/patches/clucene-pkgconfig.patch \
%D%/packages/patches/clx-remove-demo.patch \
%D%/packages/patches/coda-use-system-libs.patch \
%D%/packages/patches/combinatorial-blas-awpm.patch \
%D%/packages/patches/combinatorial-blas-io-fix.patch \
%D%/packages/patches/cool-retro-term-dont-check-uninit-member.patch \
%D%/packages/patches/cool-retro-term-fix-array-size.patch \
%D%/packages/patches/cool-retro-term-memory-leak-1.patch \
@ -652,7 +711,6 @@ dist_patch_DATA = \
%D%/packages/patches/cursynth-wave-rand.patch \
%D%/packages/patches/cvs-2017-12836.patch \
%D%/packages/patches/cyrus-sasl-CVE-2013-4122.patch \
%D%/packages/patches/datamash-arm-tests.patch \
%D%/packages/patches/dbus-helper-search-path.patch \
%D%/packages/patches/deja-dup-use-ref-keyword-for-iter.patch \
%D%/packages/patches/dfu-programmer-fix-libusb.patch \
@ -660,6 +718,8 @@ dist_patch_DATA = \
%D%/packages/patches/docbook-xsl-nonrecursive-string-subst.patch \
%D%/packages/patches/doc++-include-directives.patch \
%D%/packages/patches/doc++-segfault-fix.patch \
%D%/packages/patches/docker-engine-test-noinstall.patch \
%D%/packages/patches/docker-fix-tests.patch \
%D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch \
%D%/packages/patches/doxygen-test.patch \
%D%/packages/patches/dropbear-CVE-2018-15599.patch \
@ -674,6 +734,7 @@ dist_patch_DATA = \
%D%/packages/patches/emacs-scheme-complete-scheme-r5rs-info.patch \
%D%/packages/patches/emacs-source-date-epoch.patch \
%D%/packages/patches/emacs-realgud-fix-configure-ac.patch \
%D%/packages/patches/emacs-wordnut-require-adaptive-wrap.patch \
%D%/packages/patches/enlightenment-fix-setuid-path.patch \
%D%/packages/patches/erlang-man-path.patch \
%D%/packages/patches/eudev-rules-directory.patch \
@ -692,6 +753,7 @@ dist_patch_DATA = \
%D%/packages/patches/fcgi-2.4.0-poll.patch \
%D%/packages/patches/fifo-map-fix-flags-for-gcc.patch \
%D%/packages/patches/fifo-map-remove-catch.hpp.patch \
%D%/packages/patches/file-CVE-2018-10360.patch \
%D%/packages/patches/findutils-gnulib-libio.patch \
%D%/packages/patches/findutils-localstatedir.patch \
%D%/packages/patches/findutils-makedev.patch \
@ -766,7 +828,6 @@ dist_patch_DATA = \
%D%/packages/patches/glibc-hurd-magic-pid.patch \
%D%/packages/patches/glibc-ldd-x86_64.patch \
%D%/packages/patches/glibc-locales.patch \
%D%/packages/patches/glibc-memchr-overflow-i686.patch \
%D%/packages/patches/glibc-o-largefile.patch \
%D%/packages/patches/glibc-reinstate-prlimit64-fallback.patch \
%D%/packages/patches/glibc-vectorized-strcspn-guards.patch \
@ -780,8 +841,7 @@ dist_patch_DATA = \
%D%/packages/patches/gmp-faulty-test.patch \
%D%/packages/patches/gnome-todo-libical-compat.patch \
%D%/packages/patches/gnome-tweak-tool-search-paths.patch \
%D%/packages/patches/gnucash-price-quotes-perl.patch \
%D%/packages/patches/gnucash-disable-failing-tests.patch \
%D%/packages/patches/gnucash-fix-test-transaction-failure.patch \
%D%/packages/patches/gnutls-skip-trust-store-test.patch \
%D%/packages/patches/gnutls-skip-pkgconfig-test.patch \
%D%/packages/patches/gobject-introspection-absolute-shlib-path.patch \
@ -831,6 +891,7 @@ dist_patch_DATA = \
%D%/packages/patches/hurd-fix-eth-multiplexer-dependency.patch \
%D%/packages/patches/hplip-remove-imageprocessor.patch \
%D%/packages/patches/hydra-disable-darcs-test.patch \
%D%/packages/patches/icecat-makeicecat.patch \
%D%/packages/patches/icecat-avoid-bundled-libraries.patch \
%D%/packages/patches/icecat-use-system-graphite2+harfbuzz.patch \
%D%/packages/patches/icecat-use-system-media-libs.patch \
@ -860,13 +921,19 @@ dist_patch_DATA = \
%D%/packages/patches/kiki-makefile.patch \
%D%/packages/patches/kiki-missing-includes.patch \
%D%/packages/patches/kiki-portability-64bit.patch \
%D%/packages/patches/kinit-kdeinit-extra_libs.patch \
%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 \
%D%/packages/patches/kobodeluxe-const-charp-conversion.patch \
%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 \
@ -878,6 +945,9 @@ dist_patch_DATA = \
%D%/packages/patches/liba52-use-mtune-not-mcpu.patch \
%D%/packages/patches/libarchive-CVE-2017-14166.patch \
%D%/packages/patches/libarchive-CVE-2017-14502.patch \
%D%/packages/patches/libarchive-CVE-2018-1000877.patch \
%D%/packages/patches/libarchive-CVE-2018-1000878.patch \
%D%/packages/patches/libarchive-CVE-2018-1000880.patch \
%D%/packages/patches/libbase-fix-includes.patch \
%D%/packages/patches/libbase-use-own-logging.patch \
%D%/packages/patches/libbonobo-activation-test-race.patch \
@ -894,6 +964,8 @@ dist_patch_DATA = \
%D%/packages/patches/libevent-2.1-skip-failing-test.patch \
%D%/packages/patches/libexif-CVE-2016-6328.patch \
%D%/packages/patches/libexif-CVE-2017-7544.patch \
%D%/packages/patches/libextractor-CVE-2018-20430.patch \
%D%/packages/patches/libextractor-CVE-2018-20431.patch \
%D%/packages/patches/libgit2-mtime-0.patch \
%D%/packages/patches/libgit2-oom-test.patch \
%D%/packages/patches/libgdata-fix-tests.patch \
@ -917,7 +989,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 \
@ -940,6 +1011,7 @@ dist_patch_DATA = \
%D%/packages/patches/lierolibre-newer-libconfig.patch \
%D%/packages/patches/lierolibre-remove-arch-warning.patch \
%D%/packages/patches/lierolibre-try-building-other-arch.patch \
%D%/packages/patches/linkchecker-mark-more-tests-that-require-the-network.patch \
%D%/packages/patches/linux-pam-no-setfsuid.patch \
%D%/packages/patches/lirc-localstatedir.patch \
%D%/packages/patches/lirc-reproducible-build.patch \
@ -966,11 +1038,9 @@ dist_patch_DATA = \
%D%/packages/patches/maxima-defsystem-mkdir.patch \
%D%/packages/patches/maven-generate-component-xml.patch \
%D%/packages/patches/maven-generate-javax-inject-named.patch \
%D%/packages/patches/mcron-install.patch \
%D%/packages/patches/mcrypt-CVE-2012-4409.patch \
%D%/packages/patches/mcrypt-CVE-2012-4426.patch \
%D%/packages/patches/mcrypt-CVE-2012-4527.patch \
%D%/packages/patches/meandmyshadow-define-paths-earlier.patch \
%D%/packages/patches/mesa-skip-disk-cache-test.patch \
%D%/packages/patches/mescc-tools-boot.patch \
%D%/packages/patches/meson-for-build-rpath.patch \
@ -995,7 +1065,6 @@ dist_patch_DATA = \
%D%/packages/patches/mupen64plus-video-z64-glew-correct-path.patch \
%D%/packages/patches/mutt-store-references.patch \
%D%/packages/patches/m4-gnulib-libio.patch \
%D%/packages/patches/net-tools-bitrot.patch \
%D%/packages/patches/netcdf-date-time.patch \
%D%/packages/patches/netcdf-tst_h_par.patch \
%D%/packages/patches/netsurf-message-timestamp.patch \
@ -1010,24 +1079,22 @@ dist_patch_DATA = \
%D%/packages/patches/nvi-dbpagesize-binpower.patch \
%D%/packages/patches/nvi-db4.patch \
%D%/packages/patches/nyacc-binary-literals.patch \
%D%/packages/patches/nyx-show-header-stats-with-python3.patch \
%D%/packages/patches/oath-toolkit-glibc-compat.patch \
%D%/packages/patches/ocaml-bisect-fix-camlp4-in-another-directory.patch \
%D%/packages/patches/ocaml-bitstring-fix-configure.patch \
%D%/packages/patches/ocaml-CVE-2015-8869.patch \
%D%/packages/patches/ocaml-Add-a-.file-directive.patch \
%D%/packages/patches/ocaml-enable-ocamldoc-reproducibility.patch \
%D%/packages/patches/ocaml-findlib-make-install.patch \
%D%/packages/patches/ocaml-graph-honor-source-date-epoch.patch \
%D%/packages/patches/omake-fix-non-determinism.patch \
%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 \
@ -1035,6 +1102,7 @@ dist_patch_DATA = \
%D%/packages/patches/osip-CVE-2017-7853.patch \
%D%/packages/patches/ots-no-include-missing-file.patch \
%D%/packages/patches/owncloud-disable-updatecheck.patch \
%D%/packages/patches/p11-kit-jks-timestamps.patch \
%D%/packages/patches/p7zip-CVE-2016-9296.patch \
%D%/packages/patches/p7zip-CVE-2017-17969.patch \
%D%/packages/patches/p7zip-remove-unused-code.patch \
@ -1104,7 +1172,6 @@ dist_patch_DATA = \
%D%/packages/patches/python-cffi-x87-stack-clean.patch \
%D%/packages/patches/python-fix-tests.patch \
%D%/packages/patches/python2-larch-coverage-4.0a6-compatibility.patch \
%D%/packages/patches/python2-rdflib-drop-sparqlwrapper.patch \
%D%/packages/patches/python-configobj-setuptools.patch \
%D%/packages/patches/python-faker-fix-build-32bit.patch \
%D%/packages/patches/python-mox3-python3.6-compat.patch \
@ -1119,6 +1186,8 @@ dist_patch_DATA = \
%D%/packages/patches/python-unittest2-remove-argparse.patch \
%D%/packages/patches/python-waitress-fix-tests.patch \
%D%/packages/patches/qemu-glibc-2.27.patch \
%D%/packages/patches/qemu-CVE-2018-16872.patch \
%D%/packages/patches/qemu-CVE-2019-6778.patch \
%D%/packages/patches/qt4-ldflags.patch \
%D%/packages/patches/qtbase-use-TZDIR.patch \
%D%/packages/patches/qtscript-disable-tests.patch \
@ -1137,7 +1206,6 @@ dist_patch_DATA = \
%D%/packages/patches/rct-add-missing-headers.patch \
%D%/packages/patches/readline-link-ncurses.patch \
%D%/packages/patches/readline-6.2-CVE-2014-2524.patch \
%D%/packages/patches/readline-7.0-mingw.patch \
%D%/packages/patches/reposurgeon-add-missing-docbook-files.patch \
%D%/packages/patches/reptyr-fix-gcc-7.patch \
%D%/packages/patches/ripperx-missing-file.patch \
@ -1156,10 +1224,8 @@ dist_patch_DATA = \
%D%/packages/patches/rust-reproducible-builds.patch \
%D%/packages/patches/rxvt-unicode-escape-sequences.patch \
%D%/packages/patches/scheme48-tests.patch \
%D%/packages/patches/scotch-test-threading.patch \
%D%/packages/patches/scotch-build-parallelism.patch \
%D%/packages/patches/scotch-graph-diam-64.patch \
%D%/packages/patches/scotch-graph-induce-type-64.patch \
%D%/packages/patches/scotch-integer-declarations.patch \
%D%/packages/patches/scribus-poppler.patch \
%D%/packages/patches/sdl-libx11-1.6.patch \
%D%/packages/patches/seq24-rename-mutex.patch \
@ -1176,6 +1242,8 @@ dist_patch_DATA = \
%D%/packages/patches/soundtouch-CVE-2018-14044-14045.patch \
%D%/packages/patches/soundtouch-CVE-2018-1000223.patch \
%D%/packages/patches/steghide-fixes.patch \
%D%/packages/patches/streamlink-update-test.patch \
%D%/packages/patches/superlu-dist-awpm-grid.patch \
%D%/packages/patches/superlu-dist-scotchmetis.patch \
%D%/packages/patches/swig-guile-gc.patch \
%D%/packages/patches/swish-e-search.patch \
@ -1210,13 +1278,6 @@ dist_patch_DATA = \
%D%/packages/patches/totem-meson-easy-codec.patch \
%D%/packages/patches/tuxpaint-stamps-path.patch \
%D%/packages/patches/twinkle-include-qregexpvalidator.patch \
%D%/packages/patches/u-boot-pinebook-a64-update-dts.patch \
%D%/packages/patches/u-boot-pinebook-mmc-calibration.patch \
%D%/packages/patches/u-boot-pinebook-r_i2c-controller.patch \
%D%/packages/patches/u-boot-pinebook-dts.patch \
%D%/packages/patches/u-boot-pinebook-syscon-node.patch \
%D%/packages/patches/u-boot-pinebook-video-bridge.patch \
%D%/packages/patches/unrtf-CVE-2016-10091.patch \
%D%/packages/patches/unzip-CVE-2014-8139.patch \
%D%/packages/patches/unzip-CVE-2014-8140.patch \
%D%/packages/patches/unzip-CVE-2014-8141.patch \
@ -1236,8 +1297,11 @@ dist_patch_DATA = \
%D%/packages/patches/upx-fix-CVE-2017-15056.patch \
%D%/packages/patches/valgrind-enable-arm.patch \
%D%/packages/patches/valgrind-glibc-compat.patch \
%D%/packages/patches/vinagre-revert-1.patch \
%D%/packages/patches/vinagre-revert-2.patch \
%D%/packages/patches/vboot-utils-fix-format-load-address.patch \
%D%/packages/patches/vboot-utils-fix-tests-show-contents.patch \
%D%/packages/patches/vboot-utils-skip-test-workbuf.patch \
%D%/packages/patches/vinagre-newer-freerdp.patch \
%D%/packages/patches/vinagre-newer-rdp-parameters.patch \
%D%/packages/patches/virglrenderer-CVE-2017-6386.patch \
%D%/packages/patches/vorbis-tools-CVE-2014-9638+CVE-2014-9639.patch \
%D%/packages/patches/vorbis-tools-CVE-2014-9640.patch \
@ -1266,8 +1330,6 @@ dist_patch_DATA = \
%D%/packages/patches/wpa-supplicant-fix-nonce-reuse.patch \
%D%/packages/patches/wpa-supplicant-krack-followups.patch \
%D%/packages/patches/x265-arm-flags.patch \
%D%/packages/patches/x265-detect512-all-arches.patch \
%D%/packages/patches/xboing-CVE-2004-0149.patch \
%D%/packages/patches/xf86-video-ark-remove-mibstore.patch \
%D%/packages/patches/xf86-video-geode-glibc-2.20.patch \
%D%/packages/patches/xf86-video-i128-remove-mibstore.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:
;;;
@ -140,6 +147,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
@ -172,6 +187,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)
@ -188,7 +247,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))
@ -207,28 +294,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
@ -236,9 +356,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
@ -294,6 +469,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:

35
gnu/packages/accessibility.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2017 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2017 Stefan Reichör <stefan@xsteve.at>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Andrew Miloradovsky <andrew@interpretmath.pw>
;;;
;;; This file is part of GNU Guix.
;;;
@ -122,3 +123,37 @@ available to help to click.")
It works for both single pedal devices and three pedal devices. All supported
devices have vendorId:productId = 0c45:7403 or 0c45:7404.")
(license license:expat))))
(define-public xmagnify
(package
(name "xmagnify")
(version "0.1.0")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://gitlab.com/amiloradovsky/magnify.git")
(commit version)))
(file-name (git-file-name name version))
(sha256
(base32
"1ngnp5f5zl3v35vhbdyjpymy6mwrs0476fm5nd7dzkba7n841jdh"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; none included
#:make-flags
(list "CC=gcc"
(string-append "prefix=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
(delete 'configure))))
(inputs
`(("libX11" ,libx11)))
(home-page "https://gitlab.com/amiloradovsky/magnify")
(synopsis "Tiny screen magnifier for X11")
(description
"This program magnifies a screen region by an integer positive factor and
draws the result on a window. It is useful as an accessibility tool, which
works with every X Window System based GUI (depends only on libX11); or as an
assistant for graphic designers, who need to select individual pixels.")
;; Licensed either under Expat or GPLv2+.
(license (list license:expat license:gpl2+))))

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

42
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>
@ -23,6 +23,7 @@
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; Copyright © 2018 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2018 Pierre Neidhardt <mail@ambrevar.xyz>
;;; Copyright © 2019 Brett Gilio <brettg@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -86,6 +87,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)
@ -986,7 +988,7 @@ system administrator.")
(define-public sudo
(package
(name "sudo")
(version "1.8.26")
(version "1.8.27")
(source (origin
(method url-fetch)
(uri
@ -996,7 +998,7 @@ system administrator.")
version ".tar.gz")))
(sha256
(base32
"1qpyyfga8rs02p3186sns8qvh2bzwa48ka845nrcqh83dyd23nj0"))
"1h1f7v9pv0rzp14cxzv8kaa8mdd717fbqv83l7c5dvvi8jwnisvv"))
(modules '((guix build utils)))
(snippet
'(begin
@ -1510,7 +1512,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 +1520,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/")
@ -1567,9 +1569,7 @@ specified directories.")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/g/graphios/graphios-"
version ".tar.gz"))
(uri (pypi-uri "graphios" version))
(sha256
(base32
"1h87hvc315wg6lklbf4l7csd3n5pgljwrfli1p3nasdi0izgn66i"))))
@ -1601,14 +1601,14 @@ of supported upstream metrics systems simultaneously.")
(define-public ansible
(package
(name "ansible")
(version "2.7.5")
(version "2.7.6")
(source
(origin
(method url-fetch)
(uri (pypi-uri "ansible" version))
(sha256
(base32
"1fsif2jmkrrgiawsd8r6sxrqvh01fvrmdhas0p540a6i9fby3yda"))))
"0f7b2ghm34ql8yv90wr0ngd6w7wyvnlcxpc3snkj86kcjsnmx1bd"))))
(build-system python-build-system)
(native-inputs
`(("python-bcrypt" ,python-bcrypt)
@ -2014,7 +2014,7 @@ throughput (in the same interval).")
(define-public thefuck
(package
(name "thefuck")
(version "3.27")
(version "3.28")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/nvbn/thefuck/archive/"
@ -2022,7 +2022,7 @@ throughput (in the same interval).")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0my32n2x8x0f0wr8ql7qgk9qhb6ibv5b1rqs5b2r4nadv0gpiv96"))
"1i11qlnbg95nx7dcf6wqvfz7b230dqr5m981md4hvyaa1qw3xj5m"))
(patches (search-patches "thefuck-test-environ.patch"))))
(build-system python-build-system)
(arguments
@ -2810,17 +2810,17 @@ support forum. It runs with the @code{/exec} command in most IRC clients.")
(define-public pscircle
(package
(name "pscircle")
(version "1.1.0")
(version "1.3.0")
(source
(origin
(method url-fetch)
(uri (string-append
"https://gitlab.com/mildlyparallel/pscircle/-/archive/v"
version "/pscircle-v" version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://gitlab.com/mildlyparallel/pscircle.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1k757yf2bmgfrjd417l6kpcf83hlvi0z1791vz967mwcklrsb3fj"))))
"0qsif00dkqa8ky3vl2ycx5anx2yk62nrv47f5lrlqzclz91f00fx"))))
(build-system meson-build-system)
(native-inputs
`(("pkg-config" ,pkg-config)))
@ -2917,7 +2917,7 @@ Logitech Unifying Receiver.")
(define-public lynis
(package
(name "lynis")
(version "2.7.0")
(version "2.7.1")
(source
(origin
(method git-fetch)
@ -2927,7 +2927,7 @@ Logitech Unifying Receiver.")
(file-name (git-file-name name version))
(sha256
(base32
"0rzc0y8lk22bymf56249jzmllki2lh0rz5in4lkrc5fkmp29c2wv"))
"1nv2dqd2k2n8mcdr6xl5g713xxkgvja6487by1wn4k0b416jij9i"))
(modules '((guix build utils)))
(snippet
'(begin

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

85
gnu/packages/algebra.scm
View File

@ -1,13 +1,13 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017, 2018 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; Copyright © 2016, 2017, 2018, 2019 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2017, 2019 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -138,43 +138,46 @@ solve the shortest vector problem.")
(define-public pari-gp
(package
(name "pari-gp")
(version "2.11.1")
(source (origin
(method url-fetch)
(uri (string-append
"https://pari.math.u-bordeaux.fr/pub/pari/unix/pari-"
version ".tar.gz"))
(sha256
(base32
(name "pari-gp")
(version "2.11.1")
(source (origin
(method url-fetch)
(uri (string-append
"https://pari.math.u-bordeaux.fr/pub/pari/unix/pari-"
version ".tar.gz"))
(sha256
(base32
"1jfax92jpydjd02fwl30r6b8kfzqqd6sm4yx94gidyz9lqjb7a94"))))
(build-system gnu-build-system)
(native-inputs `(("texlive" ,texlive-tiny)))
(inputs `(("gmp" ,gmp)
("libx11" ,libx11)
("perl" ,perl)
("readline" ,readline)))
(arguments
'(#:make-flags '("all")
#:test-target "dobench"
#:phases (modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(zero?
(system* "./Configure"
(string-append "--prefix=" out)))))))))
(synopsis "PARI/GP, a computer algebra system for number theory")
(description
"PARI/GP is a widely used computer algebra system designed for fast
(build-system gnu-build-system)
(native-inputs
`(("texlive" ,(texlive-union
(list texlive-fonts-amsfonts
texlive-latex-amsfonts)))))
(inputs `(("gmp" ,gmp)
("libx11" ,libx11)
("perl" ,perl)
("readline" ,readline)))
(arguments
'(#:make-flags '("all")
#:test-target "dobench"
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(invoke "./Configure"
(string-append "--prefix="
(assoc-ref outputs "out"))))))))
(synopsis "PARI/GP, a computer algebra system for number theory")
(description
"PARI/GP is a widely used computer algebra system designed for fast
computations in number theory (factorisations, algebraic number theory,
elliptic curves...), but it also contains a large number of other useful
functions to compute with mathematical entities such as matrices,
polynomials, power series, algebraic numbers, etc., and a lot of
transcendental functions.
PARI is also available as a C library to allow for faster computations.")
(license license:gpl2+)
(home-page "https://pari.math.u-bordeaux.fr/")))
(license license:gpl2+)
(home-page "https://pari.math.u-bordeaux.fr/")))
(define-public gp2c
(package
@ -243,7 +246,7 @@ precision.")
(define-public giac-xcas
(package
(name "giac-xcas")
(version "1.5.0-19")
(version "1.5.0-37")
(source (origin
(method url-fetch)
;; "~parisse/giac" is not used because the maintainer regularly
@ -255,7 +258,7 @@ precision.")
"source/giac_" version ".tar.gz"))
(sha256
(base32
"0ds1zh712sr20qh0fih8jnm4nlv90andllp8n263qs7rlhblz551"))))
"1c6jmswv3ay13n6mjgh9w7nbpdgm5lbwdcmva5sli3vqn4chn3vq"))))
(build-system gnu-build-system)
(outputs '("out" "doc")) ;77MiB of documentation
(arguments
@ -354,11 +357,11 @@ or text interfaces) or as a C++ library.")
(mpfr (assoc-ref inputs "mpfr")))
;; do not pass "--enable-fast-install", which makes the
;; homebrew configure process fail
(zero? (system*
"./configure"
(invoke "./configure"
(string-append "--prefix=" out)
(string-append "--with-gmp=" gmp)
(string-append "--with-mpfr=" mpfr)))))))))
(string-append "--with-mpfr=" mpfr))
#t))))))
(synopsis "Fast library for number theory")
(description
"FLINT is a C library for number theory. It supports arithmetic
@ -660,7 +663,11 @@ cosine/ sine transforms or DCT/DST).")
(arguments
(substitute-keyword-arguments (package-arguments fftw)
((#:configure-flags cf)
`(cons "--enable-mpi" ,cf))))
`(cons "--enable-mpi" ,cf))
((#:phases phases '%standard-phases)
`(modify-phases ,phases
(add-before 'check 'mpi-setup
,%openmpi-setup)))))
(description
(string-append (package-description fftw)
" With OpenMPI parallelism support."))))

12
gnu/packages/android.scm
View File

@ -7,6 +7,7 @@
;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Andreas Enge <andreas@enge.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@ -37,10 +38,12 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages docker)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages linux)
#:use-module (gnu packages pcre)
#: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)
@ -48,7 +51,7 @@
#:use-module (gnu packages version-control)
#:use-module (gnu packages virtualization)
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages linux))
#:use-module (gnu packages xml))
(define-public android-make-stub
(package
@ -758,7 +761,7 @@ def _FindRepo():
(delete 'build) ; nothing to build
(replace 'check
(lambda _
(zero? (system* "python" "-m" "nose"))))
(invoke "python" "-m" "nose")))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@ -870,14 +873,14 @@ useful for reverse engineering, analysis of Android applications and more.")
(define-public fdroidserver
(package
(name "fdroidserver")
(version "1.0.10")
(version "1.1.1")
(source
(origin
(method url-fetch)
(uri (pypi-uri "fdroidserver" version))
(sha256
(base32
"0n6kkby65qzqdx1jn72grfffvr1w1j1rby5pwm9z8rymmsh8s0pm"))))
"0fp7q8faicx6i6wxm717qqaham3jpilb23mvynpz6v73z7hm6wcg"))))
(build-system python-build-system)
(arguments
`(#:phases
@ -891,6 +894,7 @@ useful for reverse engineering, analysis of Android applications and more.")
`(("python-androguard" ,python-androguard)
("python-apache-libcloud" ,python-apache-libcloud)
("python-clint" ,python-clint)
("python-defusedxml" ,python-defusedxml)
("python-docker-py" ,python-docker-py)
("python-gitpython" ,python-gitpython)
("python-mwclient" ,python-mwclient)

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

2
gnu/packages/anthy.scm
View File

@ -47,7 +47,7 @@
(replace 'check
(lambda _
(with-directory-excursion "test"
(zero? (system* "./anthy" "--all"))))))))
(invoke "./anthy" "--all")))))))
(home-page "http://anthy.osdn.jp/")
(synopsis "Japanese input method")
(description "Anthy is a Japanese input method for converting

4
gnu/packages/antivirus.scm
View File

@ -112,8 +112,10 @@
;; install sample .conf files to %output/etc rather than /etc/clamav
#:make-flags (list (string-append "sysconfdir=" %output "/etc"))
#:phases (modify-phases %standard-phases
;; Regenerate configure script. Without this we don't get
;; the correct value for LLVM linker variables.
(add-after 'unpack 'reconf
(lambda _ (zero? (system* "autoreconf" "-vfi"))))
(lambda _ (invoke "autoreconf" "-vfi")))
(add-before 'configure 'patch-llvm-config
(lambda _
(substitute* '("libclamav/c++/detect.cpp"

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

8
gnu/packages/aspell.scm
View File

@ -2,7 +2,7 @@
;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2016, 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016, 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Christopher Andersson <christopher@8bits.nu>
;;; Copyright © 2016 Theodoros Foradis <theodoros@foradis.org>
;;; Copyright © 2016, 2017 Tobias Geerinckx-Rice <me@tobias.gr>
@ -248,7 +248,7 @@ dictionaries, including personal ones.")
(string-downcase language))))
(package
(name (string-append "hunspell-dict-" nick))
(version "2017.08.24")
(version "2018.04.16")
(source (origin
(method url-fetch)
(uri (string-append
@ -256,7 +256,7 @@ dictionaries, including personal ones.")
version ".tar.gz"))
(sha256
(base32
"1kdhydzg5z5x20ad2j1x5hbdhvy08ljkfdi2v3gbyvghbagxm15s"))))
"11lkrnhwrf5mvrrq45k4mads3n9aswgac8dc25ba61c75alxb5rs"))))
(native-inputs
`(("tar" ,tar)
("gzip" ,gzip)
@ -276,7 +276,7 @@ dictionaries, including personal ones.")
(mkdir "speller/hunspell")
;; XXX: This actually builds all the dictionary variants.
(zero? (system* "make" "-C" "speller" "hunspell"))))
(invoke "make" "-C" "speller" "hunspell")))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref %outputs "out"))

87
gnu/packages/assembly.scm
View File

@ -4,6 +4,7 @@
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Guy Fleury Iteriteka <hoonandon@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -30,7 +31,9 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages python)
#:use-module (gnu packages xml))
#:use-module (gnu packages xml)
#:use-module ((guix utils)
#:select (%current-system)))
(define-public nasm
(package
@ -61,7 +64,7 @@
(add-after 'install 'install-info
(lambda _
(invoke "make" "install_doc"))))))
(home-page "http://www.nasm.us/")
(home-page "https://www.nasm.us/")
(synopsis "80x86 and x86-64 assembler")
(description
"NASM, the Netwide Assembler, is an 80x86 and x86-64 assembler designed
@ -71,7 +74,7 @@ Windows32 and Windows64. It will also output plain binary files. Its syntax
is designed to be simple and easy to understand, similar to Intel's but less
complex. It supports all currently known x86 architectural extensions, and
has strong support for macros.")
(license license:bsd-3)))
(license license:bsd-2)))
(define-public yasm
(package
@ -122,3 +125,81 @@ abstracts over the target CPU by exposing a standardized RISC instruction set
to the clients.")
(home-page "https://www.gnu.org/software/lightning/")
(license license:gpl3+)))
(define-public fasm
(package
(name "fasm")
(version "1.73.06")
(source
(origin
(method url-fetch)
(uri (string-append "https://flatassembler.net/fasm-"
version ".tgz"))
(sha256
(base32
"02wqkqxpn3p0iwcagsm92qd9cdfcnbx8a09qg03b3pjppp30hmp6"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; No tests exist
#:strip-binaries? #f ; fasm has no sections
#:phases
(modify-phases %standard-phases
(delete 'configure) ; no "configure" script exists
(replace 'build
(lambda _
(chdir "source/Linux/")
(if (string=? ,(%current-system) "x86_64-linux")
;; Use pre-compiled binaries in top-level directory to build
;; fasm.
(invoke "../../fasm.x64" "fasm.asm")
(invoke "../../fasm" "fasm.asm"))))
(replace 'install
(lambda _
(let ((out (assoc-ref %outputs "out")))
(install-file "fasm" (string-append out "/bin")))
#t)))))
(supported-systems '("x86_64-linux" "i686-linux"))
(synopsis "Assembler for x86 processors")
(description
"FASM is an assembler that supports x86 and IA-64 Intel architectures.
It does multiple passes to optimize machine code. It has macro abilities and
focuses on operating system portability.")
(home-page "https://flatassembler.net/")
(license license:bsd-2)))
(define-public dev86
(package
(name "dev86")
(version "0.16.21")
(source (origin
(method url-fetch)
(uri (string-append "http://v3.sk/~lkundrak/dev86/Dev86src-"
version ".tar.gz"))
(sha256
(base32
"154dyr2ph4n0kwi8yx0n78j128kw29rk9r9f7s2gddzrdl712jr3"))))
(build-system gnu-build-system)
(arguments
`(#:parallel-build? #f ; They use submakes wrong
#:make-flags (list "CC=gcc"
(string-append "PREFIX="
(assoc-ref %outputs "out")))
#:system "i686-linux" ; Standalone ld86 had problems otherwise
#:tests? #f ; No tests exist
#:phases
(modify-phases %standard-phases
(delete 'configure)
(add-before 'install 'mkdir
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(mkdir-p (string-append out "/bin"))
(mkdir-p (string-append out "/man/man1"))
#t))))))
(synopsis "Intel 8086 (primarily 16-bit) assembler, C compiler and
linker")
(description "This package provides a Intel 8086 (primarily 16-bit)
assembler, a C compiler and a linker. The assembler uses Intel syntax
(also Intel order of operands).")
(home-page "https://github.com/jbruchon/dev86")
(supported-systems '("i686-linux" "x86_64-linux"))
(license license:gpl2+)))

20
gnu/packages/astronomy.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@ -102,15 +103,15 @@ header.")
(define-public gnuastro
(package
(name "gnuastro")
(version "0.7")
(version "0.8")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnu/gnuastro/gnuastro-"
version ".tar.gz"))
version ".tar.lz"))
(sha256
(base32
"1h4hpj5dd1nz8hx0dkf43as0hl1grcaijg0k3zcd5djg7wgna46y"))))
"0gx6iar3z07k9sdvpa6kchsz6fpk94xn5vcvbcigssl2dwqmlnkb"))))
(inputs
`(("cfitsio" ,cfitsio)
("gsl" ,gsl)
@ -118,6 +119,8 @@ header.")
("libtiff" ,libtiff)
("wcslib" ,wcslib)
("zlib" ,zlib)))
(native-inputs
`(("lzip" ,lzip)))
(build-system gnu-build-system)
(home-page "https://www.gnu.org/software/gnuastro/")
(synopsis "Astronomy utilities")
@ -128,7 +131,7 @@ programs for the manipulation and analysis of astronomical data.")
(define-public stellarium
(package
(name "stellarium")
(version "0.18.1")
(version "0.18.3")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/Stellarium/" name
@ -136,7 +139,7 @@ programs for the manipulation and analysis of astronomical data.")
"/" name "-" version ".tar.gz"))
(sha256
(base32
"0vjkwrjy22b4wdjkafm63pmb0fck14ffnylpq8xr91ywycw4blrq"))))
"1mm8rjcb8j56m3kfigpix5vxviw1616kvl9ws2s3s5gdyngljrc3"))))
(build-system cmake-build-system)
(inputs
`(("qtbase" ,qtbase)
@ -158,6 +161,13 @@ programs for the manipulation and analysis of astronomical data.")
(assoc-ref %build-inputs "qtserialport")
"/include/qt5"))
#:phases (modify-phases %standard-phases
;; Skip a test that assumes Stellarium is "installed":
;; https://bugs.gentoo.org/674472
(add-after 'unpack 'patch-tests
(lambda _
(substitute* "src/tests/testEphemeris.cpp"
(("ifndef Q_OS_WIN") "if 0"))
#t))
(add-before 'check 'set-offscreen-display
(lambda _
;; make Qt render "offscreen", required for tests

118
gnu/packages/audio.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@ -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>
@ -17,6 +17,8 @@
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;; 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.
;;;
@ -56,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)
@ -74,12 +76,14 @@
#:use-module (gnu packages qt)
#:use-module (gnu packages libbsd)
#:use-module (gnu packages linux)
#:use-module (gnu packages libusb)
#:use-module (gnu packages llvm)
#:use-module (gnu packages mp3) ;taglib
#:use-module (gnu packages perl)
#: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)
@ -229,57 +233,79 @@ namespace ARDOUR { const char* revision = \"" version "\" ; }"))
(arguments
`(#:configure-flags '("--cxx11" ; required by gtkmm
"--no-phone-home" ; don't contact ardour.org
"--freedesktop" ; install .desktop file
"--freedesktop" ; build .desktop file
"--test") ; build unit tests
#:phases
(modify-phases %standard-phases
(add-after
'unpack 'set-rpath-in-LDFLAGS
,(ardour-rpath-phase (version-major version))))
(add-after 'unpack 'set-rpath-in-LDFLAGS
,(ardour-rpath-phase (version-major version)))
(add-after 'install 'install-freedesktop-files
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(share (string-append out "/share"))
(ver ,(version-major version)))
(for-each
(lambda (size)
(let ((dir (string-append share "/icons/hicolor/"
size "x" size "/apps")))
(mkdir-p dir)
(copy-file
(string-append "gtk2_ardour/resources/Ardour-icon_"
size "px.png")
(string-append dir "/ardour" ver ".png"))))
'("16" "22" "32" "48" "256"))
(install-file (string-append "build/gtk2_ardour/ardour"
ver ".desktop")
(string-append share "/applications/"))
(install-file (string-append "build/gtk2_ardour/ardour"
ver ".appdata.xml")
(string-append share "/appdata/")))
#t)))
#:test-target "test"
#:python ,python-2))
(inputs
`(("alsa-lib" ,alsa-lib)
("aubio" ,aubio)
("lrdf" ,lrdf)
("boost" ,boost)
("atkmm" ,atkmm)
("aubio" ,aubio)
("boost" ,boost)
("cairomm" ,cairomm)
("eudev" ,eudev)
("gtkmm" ,gtkmm-2)
("glibmm" ,glibmm)
("libart-lgpl" ,libart-lgpl)
("libgnomecanvasmm" ,libgnomecanvasmm)
("pangomm" ,pangomm)
("liblo" ,liblo)
("libsndfile" ,libsndfile)
("libsamplerate" ,libsamplerate)
("libxml2" ,libxml2)
("libogg" ,libogg)
("libvorbis" ,libvorbis)
("flac" ,flac)
("lv2" ,lv2)
("vamp" ,vamp)
("curl" ,curl)
("eudev" ,eudev)
("fftw" ,fftw)
("fftwf" ,fftwf)
("flac" ,flac)
("glibmm" ,glibmm)
("gtkmm" ,gtkmm-2)
("jack" ,jack-1)
("libarchive" ,libarchive)
("libart-lgpl" ,libart-lgpl)
("libgnomecanvasmm" ,libgnomecanvasmm)
("liblo" ,liblo)
("libogg" ,libogg)
("libsamplerate" ,libsamplerate)
("libsndfile" ,libsndfile)
("libusb" ,libusb)
("libvorbis" ,libvorbis)
("libxml2" ,libxml2)
("lilv" ,lilv)
("lrdf" ,lrdf)
("lv2" ,lv2)
("pangomm" ,pangomm)
("python-rdflib" ,python-rdflib)
("readline" ,readline)
("redland" ,redland)
("rubberband" ,rubberband)
("serd" ,serd)
("sord" ,sord)
("sratom" ,sratom)
("suil" ,suil)
("lilv" ,lilv)
("readline" ,readline)
("redland" ,redland)
("rubberband" ,rubberband)
("libarchive" ,libarchive)
("taglib" ,taglib)
("python-rdflib" ,python-rdflib)))
("vamp" ,vamp)))
(native-inputs
`(("perl" ,perl)
("cppunit" ,cppunit)
("itstool" ,itstool)
`(("cppunit" ,cppunit)
("gettext" ,gettext-minimal)
("itstool" ,itstool)
("perl" ,perl)
("pkg-config" ,pkg-config)))
(home-page "http://ardour.org")
(synopsis "Digital audio workstation")
@ -737,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
@ -746,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)
@ -1128,7 +1154,7 @@ follower.")
(define-public fluidsynth
(package
(name "fluidsynth")
(version "2.0.2")
(version "2.0.3")
(source (origin
(method git-fetch)
(uri (git-reference
@ -1137,7 +1163,7 @@ follower.")
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"02vs5sfsyh1dl7wlcvgs4w3x0qcmsl7vi000qgp99ynwh3wjb274"))))
"00f6bhw4ddrinb5flvg5y53rcvnf4km23a6nbvnswmpq13568v78"))))
(build-system cmake-build-system)
(arguments
'(#:tests? #f ; no check target
@ -1779,11 +1805,7 @@ implementation of the Open Sound Control (@dfn{OSC}) protocol.")
(source
(origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/ab/42/"
"b4f04721c5c5bfc196ce156b3c768998ef8c0ae3654ed29ea5020c749a6b"
"/PyAudio-" version ".tar.gz"))
(uri (pypi-uri "PyAudio" version))
(sha256
(base32
"0x7vdsigm7xgvyg3shd3lj113m8zqj2pxmrgdyj66kmnw0qdxgwk"))))
@ -2130,7 +2152,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)
@ -2183,7 +2209,7 @@ background file post-processing.")
(define-public supercollider
(package
(name "supercollider")
(version "3.10.0")
(version "3.10.1")
(source (origin
(method url-fetch)
(uri (string-append
@ -2192,7 +2218,7 @@ background file post-processing.")
"/SuperCollider-" version "-Source-linux.tar.bz2"))
(sha256
(base32
"16j9psa32czx1p1y2vvq0qf2ib0ngrfc604vx35n2b4llyika84v"))))
"1yszs9j3sjk8hb8xxz30z3nd4j899ymb9mw9y1v26ikd603d1iig"))))
(build-system cmake-build-system)
(arguments
`(#:configure-flags '("-DSYSTEM_BOOST=on" "-DSYSTEM_YAMLCPP=on"

6
gnu/packages/autotools.scm
View File

@ -6,7 +6,7 @@
;;; Copyright © 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
@ -205,7 +205,7 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
(define-public autoconf-archive
(package
(name "autoconf-archive")
(version "2018.03.13")
(version "2019.01.06")
(source
(origin
(method url-fetch)
@ -213,7 +213,7 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
version ".tar.xz"))
(sha256
(base32
"0ng1lvpijf3kv7w7nb1shqs23vp0398yicyvkf9lsk56kw6zjxb1"))))
"0gqya7nf4j5k98dkky0c3bnr0paciya91vkqazg7knlq621mq68p"))))
(build-system gnu-build-system)
(home-page "https://www.gnu.org/software/autoconf-archive/")
(synopsis "Collection of freely reusable Autoconf macros")

2
gnu/packages/aux-files/linux-libre/4.19-arm64.conf
View File

@ -7860,7 +7860,7 @@ CONFIG_CRYPTO_VMAC=m
#
# Digest
#
CONFIG_CRYPTO_CRC32C=m
CONFIG_CRYPTO_CRC32C=y
CONFIG_CRYPTO_CRC32=m
CONFIG_CRYPTO_CRCT10DIF=y
CONFIG_CRYPTO_GHASH=m

8603
gnu/packages/aux-files/linux-libre/4.20-arm.conf Normal file
View File

File diff suppressed because it is too large Load Diff

8381
gnu/packages/aux-files/linux-libre/4.20-arm64.conf Normal file
View File

File diff suppressed because it is too large Load Diff

9752
gnu/packages/aux-files/linux-libre/4.20-i686.conf Normal file
View File

File diff suppressed because it is too large Load Diff

9652
gnu/packages/aux-files/linux-libre/4.20-x86_64.conf Normal file
View File

File diff suppressed because it is too large Load Diff

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)

28
gnu/packages/axoloti.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016, 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -94,10 +94,10 @@
(add-after 'unpack 'patch-paths
(lambda* (#:key inputs #:allow-other-keys)
;; prepare ChibiOS
(and (zero? (system* "unzip" "-o" (assoc-ref inputs "chibios")))
(zero? (system* "mv" "ChibiOS_2.6.9" "chibios"))
(with-directory-excursion "chibios/ext"
(zero? (system* "unzip" "-o" "fatfs-0.9-patched.zip"))))
(invoke "unzip" "-o" (assoc-ref inputs "chibios"))
(invoke "mv" "ChibiOS_2.6.9" "chibios")
(with-directory-excursion "chibios/ext"
(invoke "unzip" "-o" "fatfs-0.9-patched.zip"))
;; Remove source of non-determinism in ChibiOS
(substitute* "chibios/os/various/shell.c"
@ -149,7 +149,7 @@
(string-append toolchain
"/arm-none-eabi/lib")))
(with-directory-excursion "platform_linux"
(zero? (system* "sh" "compile_firmware.sh")))))
(invoke "sh" "compile_firmware.sh"))))
(replace 'install
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@ -284,14 +284,14 @@ runtime.")
port)))
;; Build it!
(zero? (system* "ant"
(string-append "-Djavac.classpath=" classpath)
"-Dbuild.runtime=true"
"-Dbuild.time=01/01/1970 00:00:00"
"-Djavac.source=1.7"
"-Djavac.target=1.7"
(string-append "-Dtag.short.version="
,version))))))
(invoke "ant"
(string-append "-Djavac.classpath=" classpath)
"-Dbuild.runtime=true"
"-Dbuild.time=01/01/1970 00:00:00"
"-Djavac.source=1.7"
"-Djavac.target=1.7"
(string-append "-Dtag.short.version="
,version)))))
(replace 'install
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))

35
gnu/packages/backup.scm
View File

@ -11,7 +11,8 @@
;;; Copyright © 2017 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Alex Vong <alexvong1995@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -45,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)
@ -61,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)
@ -194,11 +197,12 @@ backups (called chunks) to allow easy burning to CD/DVD.")
(define-public libarchive
(package
(name "libarchive")
(replacement libarchive-3.3.3)
(version "3.3.2")
(source
(origin
(method url-fetch)
(uri (string-append "http://libarchive.org/downloads/libarchive-"
(uri (string-append "https://libarchive.org/downloads/libarchive-"
version ".tar.gz"))
(patches (search-patches "libarchive-CVE-2017-14166.patch"
"libarchive-CVE-2017-14502.patch"))
@ -258,7 +262,7 @@ backups (called chunks) to allow easy burning to CD/DVD.")
;; libarchive/test/test_write_format_gnutar_filenames.c needs to be
;; compiled with C99 or C11 or a gnu variant.
#:configure-flags '("CFLAGS=-O2 -g -std=c99")))
(home-page "http://libarchive.org/")
(home-page "https://libarchive.org/")
(synopsis "Multi-format archive and compression library")
(description
"Libarchive provides a flexible interface for reading and writing
@ -270,6 +274,22 @@ archive. In particular, note that there is currently no built-in support for
random access nor for in-place modification.")
(license license:bsd-2)))
(define-public libarchive-3.3.3
(package
(inherit libarchive)
(version "3.3.3")
(source
(origin
(method url-fetch)
(uri (string-append "https://libarchive.org/downloads/libarchive-"
version ".tar.gz"))
(patches (search-patches "libarchive-CVE-2018-1000877.patch"
"libarchive-CVE-2018-1000878.patch"
"libarchive-CVE-2018-1000880.patch"))
(sha256
(base32
"0bhfncid058p7n1n8v29l6wxm3mhdqfassscihbsxfwz3iwb2zms"))))))
(define-public rdup
(package
(name "rdup")
@ -544,6 +564,11 @@ detection, and lossless compression.")
;; HOME=/homeless-shelter.
(setenv "HOME" "/tmp")
#t)))
(add-after 'unpack 'remove-documentation-timestamps ; reproducibility
(lambda _
(substitute* "setup.py"
(("write\\(':Date:'.*") "\n"))
#t))
;; The tests need to be run after Borg is installed.
(delete 'check)
(add-after 'install 'check
@ -618,9 +643,7 @@ to not fully trusted targets. Borg is a fork of Attic.")
(version "0.16")
(source (origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/A/Attic/Attic-"
version ".tar.gz"))
(uri (pypi-uri "Attic" version))
(sha256
(base32
"0b5skd36r4c0915lwpkqg5hxm49gls9pprs1b7hc40910wlcsl36"))))

51
gnu/packages/base.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2014, 2019 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2015, 2016, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
@ -13,7 +13,7 @@
;;; Copyright © 2017, 2018 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -35,9 +35,11 @@
#:select (gpl3+ lgpl2.0+ lgpl3+ public-domain))
#:use-module (gnu packages)
#:use-module (gnu packages acl)
#:use-module (gnu packages algebra)
#:use-module (gnu packages bash)
#:use-module (gnu packages bison)
#:use-module (gnu packages ed)
#:use-module (gnu packages gcc)
#:use-module (gnu packages guile)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages compression)
@ -55,6 +57,8 @@
#:use-module (guix build-system gnu)
#:use-module (guix build-system trivial)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (glibc
libiconv-if-needed))
@ -480,6 +484,33 @@ included.")
(license gpl3+)
(home-page "https://www.gnu.org/software/binutils/")))
(define-public binutils-gold
(package
(inherit binutils)
(name "binutils-gold")
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'patch-source-shebangs 'patch-more-shebangs
(lambda _
(substitute* "gold/Makefile.in"
(("/bin/sh") (which "sh")))
#t)))
,@(substitute-keyword-arguments (package-arguments binutils)
; Upstream is aware of unrelocatable test failures on arm*.
((#:tests? _ #f)
(if (any (cute string-prefix? <> (or (%current-target-system)
(%current-system)))
'("i686" "x86_64"))
'#t '#f))
((#:configure-flags flags)
`(cons* "--enable-gold=default"
(delete "LDFLAGS=-static-libgcc" ,flags))))))
(native-inputs
`(("bc" ,bc)))
(inputs
`(("gcc:lib" ,gcc "lib")))))
(define* (make-ld-wrapper name #:key
(target (const #f))
binutils
@ -943,7 +974,7 @@ with the Linux kernel.")
(("/bin/pwd") "pwd"))
#t))))))))
(define-public glibc-locales
(define-public (make-glibc-locales glibc)
(package
(inherit glibc)
(name "glibc-locales")
@ -978,7 +1009,7 @@ the 'share/locale' sub-directory of this package.")
,(version-major+minor
(package-version glibc)))))))))))
(define-public glibc-utf8-locales
(define-public (make-glibc-utf8-locales glibc)
(package
(name "glibc-utf8-locales")
(version (package-version glibc))
@ -1028,6 +1059,18 @@ test environments.")
(home-page (package-home-page glibc))
(license (package-license glibc))))
(define-public glibc-locales
(make-glibc-locales glibc))
(define-public glibc-utf8-locales
(make-glibc-utf8-locales glibc))
(define-public glibc-locales-2.27
(package (inherit (make-glibc-locales glibc-2.27))
(name "glibc-locales-2.27")))
(define-public glibc-utf8-locales-2.27
(package (inherit (make-glibc-utf8-locales glibc-2.27))
(name "glibc-utf8-locales-2.27")))
(define-public which
(package
(name "which")

1
gnu/packages/batik.scm
View File

@ -23,7 +23,6 @@
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix build-system ant)
#:use-module (guix build utils)
#:use-module (gnu packages)
#:use-module (gnu packages compression)
#:use-module (gnu packages java)

40
gnu/packages/benchmark.scm
View File

@ -3,6 +3,7 @@
;;; Copyright © 2017 Dave Love <fx@gnu.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -23,12 +24,14 @@
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages compression)
#:use-module (gnu packages linux)
#: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))
@ -113,16 +116,15 @@ is to write a job file matching the I/O load one wants to simulate.")
(define (imb mpi)
(package
(name (string-append "imb-" (package-name mpi)))
(version "2017.2")
(version "2019.1")
(source
(origin
(method url-fetch)
(uri (match (string-split version #\.)
((major minor)
(string-append
"https://software.intel.com/sites/default/files/managed/76/6c/IMB_"
major "_Update" minor ".tgz"))))
(sha256 (base32 "11nczxm686rsppmw9gjc2p2sxc0jniv5kv18yxm1lzp5qfh5rqyb"))))
(method git-fetch)
(uri (git-reference
(url "https://github.com/intel/mpi-benchmarks.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256 (base32 "18hfdyvl5i172gadiq9si1qxif5rvic0lifxpbrr7s59ylg8f9c4"))))
(build-system gnu-build-system)
(inputs
`(("mpi" ,mpi)))
@ -134,23 +136,19 @@ is to write a job file matching the I/O load one wants to simulate.")
(replace 'build
(lambda* (#:key inputs #:allow-other-keys)
(let ((mpi-home (assoc-ref inputs "mpi")))
(zero?
;; Not safe for parallel build
(system* "make" "-C" "imb/src" "-f" "make_mpich" "SHELL=sh"
(string-append "MPI_HOME=" mpi-home))))))
;; Override default parallelism
(substitute* "Makefile"
(("make -j[[:digit:]]+")
(format #f "make -j~d" (parallel-job-count))))
(invoke "make" "SHELL=sh" "CC=mpicc" "CXX=mpic++"))))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(doc (string-append out "/share/doc/" ,name))
(bin (string-append out "/bin")))
(with-directory-excursion "imb/src"
(for-each
(lambda (file)
(install-file file bin))
'("IMB-IO" "IMB-EXT" "IMB-MPI1" "IMB-NBC" "IMB-RMA")))
(mkdir-p doc)
(with-directory-excursion "imb"
(copy-recursively "license" doc)))
(for-each
(lambda (file)
(install-file file bin))
'("IMB-IO" "IMB-EXT" "IMB-MPI1" "IMB-NBC" "IMB-RMA" "IMB-MT")))
#t)))))
(home-page "https://software.intel.com/en-us/articles/intel-mpi-benchmarks")
(synopsis "Intel MPI Benchmarks")

138
gnu/packages/bioconductor.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Roel Janssen <roel@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017, 2018 Roel Janssen <roel@gnu.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@ -197,7 +197,84 @@ default." )
genomes and gene ID formats, largely based on the UCSC table browser.")
(license license:lgpl2.0+)))
(define-public r-txdb-mmusculus-ucsc-mm9-knowngene
(package
(name "r-txdb-mmusculus-ucsc-mm9-knowngene")
(version "3.2.2")
(source (origin
(method url-fetch)
;; We cannot use bioconductor-uri here because this tarball is
;; located under "data/annotation/" instead of "bioc/".
(uri (string-append "https://bioconductor.org/packages/"
"release/data/annotation/src/contrib"
"/TxDb.Mmusculus.UCSC.mm9.knownGene_"
version ".tar.gz"))
(sha256
(base32
"16bjxy00363hf91ik2mqlqls86i07gia72qh92xc3l1ncch61mx2"))))
(properties
`((upstream-name . "TxDb.Mmusculus.UCSC.mm9.knownGene")))
(build-system r-build-system)
(propagated-inputs
`(("r-genomicfeatures" ,r-genomicfeatures)
("r-annotationdbi" ,r-annotationdbi)))
(home-page
"https://bioconductor.org/packages/TxDb.Mmusculus.UCSC.mm9.knownGene/")
(synopsis "Annotation package for mouse genome in TxDb format")
(description
"This package provides an annotation database of Mouse genome data. It
is derived from the UCSC mm9 genome and based on the \"knownGene\" track. The
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")
@ -411,14 +488,14 @@ determining dependencies between variables, code improvement suggestions.")
(define-public r-chippeakanno
(package
(name "r-chippeakanno")
(version "3.16.0")
(version "3.16.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "ChIPpeakAnno" version))
(sha256
(base32
"09fhh1355diip3v3c0skmp1336vclipkm5nv02qvp5902v4262y3"))))
"1x98d8iwrxjwdz1s5cnvi6flynw9gdkmara9gwf205qxgmy7j3a3"))))
(properties `((upstream-name . "ChIPpeakAnno")))
(build-system r-build-system)
(propagated-inputs
@ -778,14 +855,14 @@ trees and clusters to other programs.")
(define-public r-goseq
(package
(name "r-goseq")
(version "1.34.0")
(version "1.34.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "goseq" version))
(sha256
(base32
"1401x0jn5f8hqc12r3gd1wammp1nxir3is1k5ldd03ln97x00i7a"))))
"1j87j98cajcjqabv6rb6zmcqxsqxxhbb3w60w1iink4rhsh8m3mn"))))
(build-system r-build-system)
(propagated-inputs
`(("r-annotationdbi" ,r-annotationdbi)
@ -804,14 +881,14 @@ defined categories which are over/under represented in RNA-seq data.")
(define-public r-glimma
(package
(name "r-glimma")
(version "1.10.0")
(version "1.10.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "Glimma" version))
(sha256
(base32
"0cbsi6g8k1whkh21jxfn22sj7wry2g3rshiracf5nyvrl2fnl947"))))
"1ihrww55sa7ipi1rpp0rmn081sbqdwdmm5mz30zfrjr1xxqcdbcv"))))
(properties `((upstream-name . "Glimma")))
(build-system r-build-system)
(propagated-inputs
@ -831,14 +908,14 @@ information.")
(define-public r-rots
(package
(name "r-rots")
(version "1.10.0")
(version "1.10.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "ROTS" version))
(sha256
(base32
"137c06g5w7mjw3b1mly7b7n9iix4fcy23c7a9ym9iz8dazwhzwn5"))))
"1d5ggkk47xybcaizfy756qimbf2falg9cld46mhqjp3xfbfvzsg6"))))
(properties `((upstream-name . "ROTS")))
(build-system r-build-system)
(propagated-inputs
@ -852,33 +929,64 @@ information.")
in omics data.")
(license license:gpl2+)))
(define-public r-plgem
(package
(name "r-plgem")
(version "1.54.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "plgem" version))
(sha256
(base32
"1330635db3p8xm5y8fwrk1l37r6bgypsq70s3rx954i775zp6szg"))))
(build-system r-build-system)
(propagated-inputs
`(("r-biobase" ,r-biobase)
("r-mass" ,r-mass)))
(home-page "http://www.genopolis.it")
(synopsis "Detect differential expression in microarray and proteomics datasets")
(description
"The Power Law Global Error Model (PLGEM) has been shown to faithfully
model the variance-versus-mean dependence that exists in a variety of
genome-wide datasets, including microarray and proteomics data. The use of
PLGEM has been shown to improve the detection of differentially expressed
genes or proteins in these datasets.")
(license license:gpl2)))
(define-public r-inspect
(package
(name "r-inspect")
(version "1.12.0")
(version "1.12.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "INSPEcT" version))
(sha256
(base32
"0b671x5v2wyq5np2flq2m1fnjz32f303yjlw64a1inwc9k2w2pz2"))))
"07q5msw9rnamx957mbiawnv3p9kr5ahwawzvv9xzla7d3lkk62xp"))))
(properties `((upstream-name . "INSPEcT")))
(build-system r-build-system)
(propagated-inputs
`(("r-biobase" ,r-biobase)
("r-biocgenerics" ,r-biocgenerics)
("r-biocparallel" ,r-biocparallel)
("r-deseq2" ,r-deseq2)
("r-desolve" ,r-desolve)
("r-genomicalignments" ,r-genomicalignments)
("r-genomicfeatures" ,r-genomicfeatures)
("r-genomicranges" ,r-genomicranges)
("r-iranges" ,r-iranges)
("r-plgem" ,r-plgem)
("r-preprocesscore" ,r-preprocesscore)
("r-proc" ,r-proc)
("r-rootsolve" ,r-rootsolve)
("r-rsamtools" ,r-rsamtools)
("r-s4vectors" ,r-s4vectors)))
("r-s4vectors" ,r-s4vectors)
("r-shiny" ,r-shiny)
("r-summarizedexperiment" ,r-summarizedexperiment)
("r-txdb-mmusculus-ucsc-mm9-knowngene"
,r-txdb-mmusculus-ucsc-mm9-knowngene)))
(home-page "https://bioconductor.org/packages/INSPEcT")
(synopsis "Analysis of 4sU-seq and RNA-seq time-course data")
(description
@ -918,14 +1026,14 @@ demultiplexed, i.e. assigned to their original reference barcode.")
(define-public r-ruvseq
(package
(name "r-ruvseq")
(version "1.16.0")
(version "1.16.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "RUVSeq" version))
(sha256
(base32
"0xb3bj3n06cb9xddkv77a8svhg4fl1azlfmibwrm9mq9464kgf0m"))))
"0qk7q3ab7k133divfkp54zsmvsmb9p8r09pkh2caswrzrn8achzv"))))
(properties `((upstream-name . "RUVSeq")))
(build-system r-build-system)
(propagated-inputs

315
gnu/packages/bioinformatics.scm
View File

@ -1,10 +1,10 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2016, 2017, 2018 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2015, 2016 Pjotr Prins <pjotr.guix@thebird.nl>
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016, 2017, 2018, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2016, 2018 Raoul Bonnal <ilpuccio.febo@gmail.com>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
@ -72,12 +72,14 @@
#:use-module (gnu packages graph)
#:use-module (gnu packages groff)
#:use-module (gnu packages guile)
#:use-module (gnu packages guile-xyz)
#:use-module (gnu packages haskell)
#:use-module (gnu packages haskell-check)
#:use-module (gnu packages haskell-web)
#:use-module (gnu packages image)
#:use-module (gnu packages imagemagick)
#:use-module (gnu packages java)
#:use-module (gnu packages java-compression)
#:use-module (gnu packages jemalloc)
#:use-module (gnu packages dlang)
#:use-module (gnu packages linux)
@ -97,7 +99,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)
@ -2298,6 +2302,22 @@ data and settings.")
("cairo" ,cairo)))
(native-inputs
`(("texlive" ,texlive)
;; TODO: Replace texlive with minimal texlive-union.
;; ("texlive" ,(texlive-union (list texlive-latex-doi
;; texlive-latex-hyperref
;; texlive-latex-oberdiek
;; texlive-generic-ifxetex
;; texlive-latex-url
;; texlive-latex-pgf
;; texlive-latex-examplep
;; texlive-latex-natbib
;; texlive-latex-verbatimbox
;; texlive-latex-ms
;; texlive-latex-xcolor
;; texlive-fonts-amsfonts
;; texlive-latex-amsfonts
;; ;; ...
;; )))
("imagemagick" ,imagemagick)))
(home-page "http://dorina.mdc-berlin.de/public/rajewsky/discrover/")
(synopsis "Discover discriminative nucleotide sequence motifs")
@ -4484,9 +4504,7 @@ files and writing bioinformatics applications.")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/W/WarpedLMM/WarpedLMM-"
version ".zip"))
(uri (pypi-uri "WarpedLMM" version ".zip"))
(sha256
(base32
"1agfz6zqa8nc6cw47yh0s3y14gkpa9wqazwcj7mwwj3ffnw39p3j"))))
@ -6002,7 +6020,7 @@ application of SortMeRNA is filtering rRNA from metatranscriptomic data.")
(define-public star
(package
(name "star")
(version "2.6.0c")
(version "2.7.0a")
(source (origin
(method git-fetch)
(uri (git-reference
@ -6011,7 +6029,7 @@ application of SortMeRNA is filtering rRNA from metatranscriptomic data.")
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"04cj6jw8d9q6lk9c78wa4fky6jdlicf1d13plq7182h8vqiz8p59"))
"1yx28gra6gqdx1ps5y8mpdinsn8r0dhsc2m3gcvjfrk71i9yhd6l"))
(modules '((guix build utils)))
(snippet
'(begin
@ -6321,63 +6339,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")
@ -6456,14 +6417,14 @@ high-throughput sequencing experiments.")
(define-public r-deseq2
(package
(name "r-deseq2")
(version "1.22.1")
(version "1.22.2")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "DESeq2" version))
(sha256
(base32
"1b2bmvcsfzvks47d7w46zplcwz0kgcdhx5xmx3x9lp2gvx2p84r5"))))
"0n5ah84mxn87p45drzy0wh2yknmzj1q5i6gv0v9vgg1lj7awb91r"))))
(properties `((upstream-name . "DESeq2")))
(build-system r-build-system)
(propagated-inputs
@ -6493,14 +6454,14 @@ distribution.")
(define-public r-dexseq
(package
(name "r-dexseq")
(version "1.28.0")
(version "1.28.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "DEXSeq" version))
(sha256
(base32
"0jh1640cnzpk8x3155cqc8dvrs1rciw3d6nv2k70baw96bhrynp8"))))
"0g5w9bn2nb3m670hkcsnhfvvkza2318z9irlhhwhb3n8rdzlsdym"))))
(properties `((upstream-name . "DEXSeq")))
(build-system r-build-system)
(propagated-inputs
@ -6566,14 +6527,14 @@ databases. Packages produced are intended to be used with AnnotationDbi.")
(define-public r-rbgl
(package
(name "r-rbgl")
(version "1.58.0")
(version "1.58.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "RBGL" version))
(sha256
(base32
"0jy95m38c4qp0a12097hhm2gg63k96k6ydhb11dy379h3ziapcar"))))
"1l5x2icv9di1lr3gqfi0vjnyd9xc3l77yc42ippqd4cadj3d1pzf"))))
(properties `((upstream-name . "RBGL")))
(build-system r-build-system)
(propagated-inputs `(("r-graph" ,r-graph)))
@ -6718,14 +6679,14 @@ ungapped alignment formats.")
(define-public r-systempiper
(package
(name "r-systempiper")
(version "1.16.0")
(version "1.16.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "systemPipeR" version))
(sha256
(base32
"0l26q8zjdmzg84g7f25gv9z60sykybahlpg5bg9bmpbg5lzcsx04"))))
"0qzydz87rld2nhwzbfgrw5jfgh8maa9y54mjx9c4285m11qj2shq"))))
(properties `((upstream-name . "systemPipeR")))
(build-system r-build-system)
(propagated-inputs
@ -7075,26 +7036,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")
@ -7117,13 +7058,13 @@ Bioconductor, CRAN, and Github.")
(define-public r-biocviews
(package
(name "r-biocviews")
(version "1.50.5")
(version "1.50.10")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "biocViews" version))
(sha256
(base32
"0rc1n89n04ylvy9gvsgvizcs77bh70jg1nkjjsjs7rqbr3zzdysz"))))
"06ms82pyc5rxbd9crfvqjxcwpafv0c627i83v80d12925mrc51h8"))))
(properties
`((upstream-name . "biocViews")))
(build-system r-build-system)
@ -7144,13 +7085,13 @@ also known as views, in a controlled vocabulary.")
(define-public r-bookdown
(package
(name "r-bookdown")
(version "0.7")
(version "0.9")
(source (origin
(method url-fetch)
(uri (cran-uri "bookdown" version))
(sha256
(base32
"1b3fw1f41zph5yw3kynb47aijq53vhaa6mnnvxly72zamyzdf95q"))))
"0vg1s1w0l9pm95asqb21yf39mfk1nc9rdhmlys9xwr7p7i7rsz32"))))
(build-system r-build-system)
(propagated-inputs
`(("r-htmltools" ,r-htmltools)
@ -7241,14 +7182,14 @@ checks on R packages that are to be submitted to the Bioconductor repository.")
(define-public r-optparse
(package
(name "r-optparse")
(version "1.6.0")
(version "1.6.1")
(source
(origin
(method url-fetch)
(uri (cran-uri "optparse" version))
(sha256
(base32
"1d7v5gl45x4amsfmzn5zyyffyqlc7a82h01szlnda22viyxids0h"))))
"04vyb6dhcga30mvghsg1p052jmf69xqxkvh3hzqz7dscyppy76w1"))))
(build-system r-build-system)
(propagated-inputs
`(("r-getopt" ,r-getopt)))
@ -7418,13 +7359,13 @@ names in their natural, rather than lexicographic, order.")
(define-public r-edger
(package
(name "r-edger")
(version "3.24.0")
(version "3.24.3")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "edgeR" version))
(sha256
(base32
"0ihihgzrgb4q3xc8xkzp1v76ndgihrj4gas00fa25vggfs1v6hvg"))))
"15yimsbsxmxhlsfmgw5j7fd8qn08zz4xqxrir1c6n2dc103y22xg"))))
(properties `((upstream-name . "edgeR")))
(build-system r-build-system)
(propagated-inputs
@ -7446,13 +7387,13 @@ CAGE.")
(define-public r-variantannotation
(package
(name "r-variantannotation")
(version "1.28.1")
(version "1.28.10")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "VariantAnnotation" version))
(sha256
(base32
"0gvah258mkaafhbna81zwknx8qr3lidbcx5qvwk39q3yswr9mi49"))))
"0kxf583cgkdz1shi85r0mpnfxmzi7s5f6srd1czbdl2iibvrm8jn"))))
(properties
`((upstream-name . "VariantAnnotation")))
(inputs
@ -7484,13 +7425,13 @@ coding changes and predict coding outcomes.")
(define-public r-limma
(package
(name "r-limma")
(version "3.38.2")
(version "3.38.3")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "limma" version))
(sha256
(base32
"1wkh362rmn24q7bkinb6nx62a31wl3r3myg5l326gx65wpwdnx97"))))
"08va8jggmv61wym955mnb1n31mgikrmjys7dl1kp5hp3yia8jg7l"))))
(build-system r-build-system)
(home-page "http://bioinf.wehi.edu.au/limma")
(synopsis "Package for linear models for microarray and RNA-seq data")
@ -7650,13 +7591,13 @@ powerful online queries from gene annotation to database mining.")
(define-public r-biocparallel
(package
(name "r-biocparallel")
(version "1.16.0")
(version "1.16.5")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "BiocParallel" version))
(sha256
(base32
"0g16cy0vjapqkb188z63r1b6y96m9g8vx0a3v2qavzxc177k0cja"))))
"1164dk0fajb2vrkfpcjs11055qf1cs4vvbnq0aqdaaf2p4lyx41l"))))
(properties
`((upstream-name . "BiocParallel")))
(build-system r-build-system)
@ -7675,13 +7616,13 @@ objects.")
(define-public r-biostrings
(package
(name "r-biostrings")
(version "2.50.1")
(version "2.50.2")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "Biostrings" version))
(sha256
(base32
"1qyv1ps7vy6gy78pm2rcikg0bgf1mv7falahjp3pkwqq1272hrl8"))))
"16cqqc8i6gb0jcz0lizfqqxsq7g0yb0ll2s9qzmb45brp07dg8f7"))))
(properties
`((upstream-name . "Biostrings")))
(build-system r-build-system)
@ -7807,13 +7748,13 @@ samples.")
(define-public r-genomicalignments
(package
(name "r-genomicalignments")
(version "1.18.0")
(version "1.18.1")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "GenomicAlignments" version))
(sha256
(base32
"0a3zhwripfw2508fvgx3wzqa8nq8vnslg97a911znpwvxh53jl24"))))
"1maslav2r34wjyzh2nlwa862in1ir7i5xk57nw2nlfh5gqy112jd"))))
(properties
`((upstream-name . "GenomicAlignments")))
(build-system r-build-system)
@ -7840,13 +7781,13 @@ alignments.")
(define-public r-rtracklayer
(package
(name "r-rtracklayer")
(version "1.42.0")
(version "1.42.1")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "rtracklayer" version))
(sha256
(base32
"0a4mhd926w9slkfil5xgngjsfdj024a4w57w2bm3d4r0pj8y5da7"))))
"1ycmcxvgvszvjv75hlmg0i6pq8i7r8720vgmfayb905s9l6j82x6"))))
(build-system r-build-system)
(arguments
`(#:phases
@ -7887,13 +7828,13 @@ as well as query and modify the browser state, such as the current viewport.")
(define-public r-genomicfeatures
(package
(name "r-genomicfeatures")
(version "1.34.1")
(version "1.34.2")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "GenomicFeatures" version))
(sha256
(base32
"0slq6hv5bmc3bgrl824jzmr6db3fvaj6b7ihwmdn76pgqqbq2fq6"))))
"0qs94b0ywrjyc9m1jykrbch3lb07576m508dikvx18vwn304mban"))))
(properties
`((upstream-name . "GenomicFeatures")))
(build-system r-build-system)
@ -8544,7 +8485,7 @@ throughput genetic sequencing data sets using regression methods.")
(define-public r-qtl
(package
(name "r-qtl")
(version "1.42-8")
(version "1.44-9")
(source
(origin
(method url-fetch)
@ -8552,7 +8493,7 @@ throughput genetic sequencing data sets using regression methods.")
version ".tar.gz"))
(sha256
(base32
"1l528dwvfpdlr05imrrm4rq32axp6hld9nqm6mm43kn5n7z2f5k6"))))
"03lmvydln8b7666b6w46qbryhf83vsd11d4y2v95rfgvqgq66l1i"))))
(build-system r-build-system)
(home-page "http://rqtl.org/")
(synopsis "R package for analyzing QTL experiments in genetics")
@ -8937,13 +8878,13 @@ kernels, including: gkmSVM, kmer-SVM, mismatch kernel and wildcard kernel.")
(define-public r-tximport
(package
(name "r-tximport")
(version "1.10.0")
(version "1.10.1")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "tximport" version))
(sha256
(base32
"0za2js8hqjgz8ria09cglynffj4w9vrzg85nmn1xgpvmc1xk813h"))))
"16wp09dm0cpb4mc00nmglfb8ica7qb4a55vm8ajgzyagbpfdd44l"))))
(build-system r-build-system)
(home-page "https://bioconductor.org/packages/tximport")
(synopsis "Import and summarize transcript-level estimates for gene-level analysis")
@ -8959,13 +8900,13 @@ of gene-level counts.")
(define-public r-rhdf5
(package
(name "r-rhdf5")
(version "2.26.0")
(version "2.26.2")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "rhdf5" version))
(sha256
(base32
"0xmpkfdsmgl79ffffj7cf9fx3zxki2rk0xn25k778kr3s0sbmhis"))))
"10zkw3k13wmvyif417gplyf6rwp2gpkjasw97lhwv2f9i32rry9l"))))
(build-system r-build-system)
(propagated-inputs
`(("r-rhdf5lib" ,r-rhdf5lib)))
@ -9189,8 +9130,7 @@ may optionally be provided to further inform the peak-calling process.")
(version "1.0.9")
(source (origin
(method url-fetch)
(uri (string-append "https://pypi.python.org/packages/source/P"
"/PePr/PePr-" version ".tar.gz"))
(uri (pypi-uri "PePr" version))
(sha256
(base32
"0qxjfdpl1b1y53nccws2d85f6k74zwmx8y8sd9rszcqhfayx6gdx"))))
@ -9344,14 +9284,14 @@ GenomicRanges Bioconductor package.")
(define-public r-copywriter
(package
(name "r-copywriter")
(version "2.14.0")
(version "2.14.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "CopywriteR" version))
(sha256
(base32
"0aamxafdk98n7s92jyqs65d6ljpnc2463vanvsw80p44qn6l6awn"))))
"1hbiw0m9hmx4na9v502pxf8y5wvxzr68r4d3fqr2755gxx86qck6"))))
(properties `((upstream-name . "CopywriteR")))
(build-system r-build-system)
(propagated-inputs
@ -9384,13 +9324,13 @@ number detection tools.")
(define-public r-methylkit
(package
(name "r-methylkit")
(version "1.8.0")
(version "1.8.1")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "methylKit" version))
(sha256
(base32
"0mz6lil1wax931incnw5byx0v9i8ryhwq9mv0nv8s48ai33ch3x6"))))
"1zcfwy7i10aqgnf7r0c41hakb5aai3s3n9y8pc6a98vimz51ly2z"))))
(properties `((upstream-name . "methylKit")))
(build-system r-build-system)
(propagated-inputs
@ -9430,14 +9370,14 @@ TAB-Seq.")
(define-public r-sva
(package
(name "r-sva")
(version "3.30.0")
(version "3.30.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "sva" version))
(sha256
(base32
"1xf0hlrqjxl0y3x13mrkxghiv39fd9v2g8gq3qzbf1wj7il6bph3"))))
"0czja4c5jxa0g3fspi90nyajqmvzb29my4ykv2wi66h43f5dlwhq"))))
(build-system r-build-system)
(propagated-inputs
`(("r-genefilter" ,r-genefilter)
@ -9460,14 +9400,14 @@ unmodeled, or latent sources of noise.")
(define-public r-seqminer
(package
(name "r-seqminer")
(version "6.1")
(version "7.1")
(source
(origin
(method url-fetch)
(uri (cran-uri "seqminer" version))
(sha256
(base32
"15yhg4vfc7jg1jnqb3371j00pgbmbyc9l1xx63hq1l3p34lazq2l"))))
"1jydcpkw4rwfp983j83kipvsvr10as9pb49zzn3c2v09k1gh3ymy"))))
(build-system r-build-system)
(inputs
`(("zlib" ,zlib)))
@ -9560,14 +9500,14 @@ proteomics packages.")
(define-public r-mzr
(package
(name "r-mzr")
(version "2.16.0")
(version "2.16.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "mzR" version))
(sha256
(base32
"0li1y6p95ljiva4lvfmql9sipn4dq42sknbh60b36ycjppnf8lj5"))
"0mlwg646k49klxrznckzfv54a9mz6irj42fqpaaa0xjm6cw2lwaa"))
(modules '((guix build utils)))
(snippet
'(begin
@ -9698,14 +9638,14 @@ and specific in detecting differential transcription.")
(define-public r-mzid
(package
(name "r-mzid")
(version "1.20.0")
(version "1.20.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "mzID" version))
(sha256
(base32
"08jbq223viwknsmsi30hyxyxslvmb0l4wx3vmqlkl6qk4vfmxzjz"))))
"15yd4bdxprw3kg7zj2k652y3yr3si781iw28jqvnkm0gsc23rd0c"))))
(properties `((upstream-name . "mzID")))
(build-system r-build-system)
(propagated-inputs
@ -9758,14 +9698,14 @@ structure (pcaRes) to provide a common interface to the PCA results.")
(define-public r-msnbase
(package
(name "r-msnbase")
(version "2.8.1")
(version "2.8.3")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "MSnbase" version))
(sha256
(base32
"0y658anh06vnvbkfs7r8q40gqgyqr2r8kj7jlpnp33fy1lvp1nv7"))))
"1kl1d7byphnfpmbl5fzbgs68dxskhpsdyx7ka51bpfn0nv3pp492"))))
(properties `((upstream-name . "MSnbase")))
(build-system r-build-system)
(propagated-inputs
@ -9801,14 +9741,14 @@ of mass spectrometry based proteomics data.")
(define-public r-msnid
(package
(name "r-msnid")
(version "1.16.0")
(version "1.16.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "MSnID" version))
(sha256
(base32
"0hgq4argllhh5hvxqi8vkf1blc3nibsslhx4zsv2mcv4yj75bv4n"))))
"077n6ljcnnl7q4w0qj8v46vm4sjk9vzzfqf7wsc6lz0wmyzqdng3"))))
(properties `((upstream-name . "MSnID")))
(build-system r-build-system)
(propagated-inputs
@ -9930,14 +9870,14 @@ classes.")
(define-public r-deseq
(package
(name "r-deseq")
(version "1.34.0")
(version "1.34.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "DESeq" version))
(sha256
(base32
"1klv1xrh3173srywr6dnq6i7m9djn4gc9aflr1p3a6yjlqcq6fya"))))
"0bpiixczbhlyaiinpbl6xrpmv72k2bq76bxnw06gl35m4pgs94p2"))))
(properties `((upstream-name . "DESeq")))
(build-system r-build-system)
(propagated-inputs
@ -9961,14 +9901,14 @@ distribution.")
(define-public r-edaseq
(package
(name "r-edaseq")
(version "2.16.0")
(version "2.16.3")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "EDASeq" version))
(sha256
(base32
"1gjqzn1kg9qwyz2gwjyy9xzzr1lnc7xd5zwdyvzkadz97gckzxwf"))))
"0559ph606ps2g9bwbl0a2knkcs5w581n9igngpjxvk5p56k24gb5"))))
(properties `((upstream-name . "EDASeq")))
(build-system r-build-system)
(propagated-inputs
@ -9976,6 +9916,7 @@ distribution.")
("r-aroma-light" ,r-aroma-light)
("r-biobase" ,r-biobase)
("r-biocgenerics" ,r-biocgenerics)
("r-biocmanager" ,r-biocmanager)
("r-biomart" ,r-biomart)
("r-biostrings" ,r-biostrings)
("r-deseq" ,r-deseq)
@ -10023,14 +9964,14 @@ Shiny-based display methods for Bioconductor objects.")
(define-public r-annotationhub
(package
(name "r-annotationhub")
(version "2.14.1")
(version "2.14.2")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "AnnotationHub" version))
(sha256
(base32
"00288x3na0izpmbcvsqac1br1qwry86vwc2slj1l47crdfb7za6c"))))
"17fgrvcnbii9siv5rq5j09bxhqffx47f6jf10418qvr7hh61ic1g"))))
(properties `((upstream-name . "AnnotationHub")))
(build-system r-build-system)
(propagated-inputs
@ -10112,14 +10053,14 @@ microarrays or GRanges for sequencing data.")
(define-public r-gage
(package
(name "r-gage")
(version "2.32.0")
(version "2.32.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "gage" version))
(sha256
(base32
"07b098wvryxf0zd423nk6h52s3gyngwjcx2vplqybpbpgl8h2931"))))
"02g796sb1800ff0f1mq9f2m5wwzpf8pnfzajs49i68dhq2hm01a8"))))
(build-system r-build-system)
(propagated-inputs
`(("r-annotationdbi" ,r-annotationdbi)
@ -10204,14 +10145,14 @@ self-defined annotation graphics.")
(define-public r-dirichletmultinomial
(package
(name "r-dirichletmultinomial")
(version "1.24.0")
(version "1.24.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "DirichletMultinomial" version))
(sha256
(base32
"19bzn0a5jal1xv0ad6wikxc7wrk582hczqamlln0vb2ffwkj1z3f"))))
"0vazfjzqy78p5g7dnv30lbqbj4bhq4zafd2wh6gdwy2il1fd78xa"))))
(properties
`((upstream-name . "DirichletMultinomial")))
(build-system r-build-system)
@ -10233,14 +10174,14 @@ originally made available by Holmes, Harris, and Quince, 2012, PLoS ONE 7(2):
(define-public r-ensembldb
(package
(name "r-ensembldb")
(version "2.6.2")
(version "2.6.3")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "ensembldb" version))
(sha256
(base32
"0hdz1f34v7sas2v4225icwl3wd4sf17ykpd5dkbx1hc7wcy4w3np"))))
"0kzdsfk6mdwlp57sw4j2cf7lx5nc67v5j0xr3iag9kzmgikaq1lb"))))
(build-system r-build-system)
(propagated-inputs
`(("r-annotationdbi" ,r-annotationdbi)
@ -10308,14 +10249,14 @@ the fact that each of these packages implements a select methods.")
(define-public r-biovizbase
(package
(name "r-biovizbase")
(version "1.30.0")
(version "1.30.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "biovizBase" version))
(sha256
(base32
"0v54mcn3rnnfx8dmcrms5z3rgq19n3hp4r23azlgzwq6hjw7cccx"))))
"0v5gvcx180qn5487i1dph9abadw3ggqwp5yzy41jswzbdc8q6sbm"))))
(properties `((upstream-name . "biovizBase")))
(build-system r-build-system)
(propagated-inputs
@ -10645,14 +10586,14 @@ family of feature/genome hypotheses.")
(define-public r-gviz
(package
(name "r-gviz")
(version "1.26.0")
(version "1.26.4")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "Gviz" version))
(sha256
(base32
"05zk9hf30afg6rjg97lzn5v8xij90v8zm09y9vcz0asmc3c8xs0a"))))
"0jvcivgw0ahv2rjadxmrww76xambhf7silczmh38nn4yn4qw6w9y"))))
(properties `((upstream-name . "Gviz")))
(build-system r-build-system)
(propagated-inputs
@ -10806,14 +10747,14 @@ provided.")
(define-public r-qvalue
(package
(name "r-qvalue")
(version "2.14.0")
(version "2.14.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "qvalue" version))
(sha256
(base32
"03qxshqwwq1rj23p6pjrz08jm3ziikvy9badi4mz2rcwy2nz783a"))))
"0kxavzm1j2mk26qicmjm90nxx4w5h3dxighzks7wzihay3k8cysc"))))
(build-system r-build-system)
(propagated-inputs
`(("r-ggplot2" ,r-ggplot2)
@ -10835,14 +10776,14 @@ problems in genomics, brain imaging, astrophysics, and data mining.")
(define-public r-hdf5array
(package
(name "r-hdf5array")
(version "1.10.0")
(version "1.10.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "HDF5Array" version))
(sha256
(base32
"1w7ad8cfsbh5xx82m3l4lc0vbmj9lcsqxxpiy3ana2ycgn1bqv3g"))))
"1qwdsygcadl58qj598hfyvs8hp0hqcl9ghnhknahrlhmb7k2bd2d"))))
(properties `((upstream-name . "HDF5Array")))
(build-system r-build-system)
(propagated-inputs
@ -10861,14 +10802,14 @@ block processing.")
(define-public r-rhdf5lib
(package
(name "r-rhdf5lib")
(version "1.4.0")
(version "1.4.2")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "Rhdf5lib" version))
(sha256
(base32
"01gpz780g850ql20b2ql6pvr678ydk4nq4sn5iiih94a4crb9lz1"))
"06bxd3wz8lrvh2hzvmjpdv4lvzj5lz9353bw5b3zb98cb8w9r2j5"))
(modules '((guix build utils)))
(snippet
'(begin
@ -10961,14 +10902,14 @@ matrices.")
(define-public r-singlecellexperiment
(package
(name "r-singlecellexperiment")
(version "1.4.0")
(version "1.4.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "SingleCellExperiment" version))
(sha256
(base32
"19r4r7djrn46qlijkj1g926vcklxzcrxjlxv6cg43m9j9jgfs3dj"))))
"12139kk9cqgzpm6f3cwdsq31gj5lxamz2q939dy9fa0fa54gdaq4"))))
(properties
`((upstream-name . "SingleCellExperiment")))
(build-system r-build-system)
@ -10988,13 +10929,13 @@ libraries.")
(define-public r-scater
(package
(name "r-scater")
(version "1.10.0")
(version "1.10.1")
(source (origin
(method url-fetch)
(uri (bioconductor-uri "scater" version))
(sha256
(base32
"1kwa9n70c5j0xcj6nkmlkzjr63cnj78mp8nhg58n07fq1ijm4ns3"))))
"0rijhy7g5qmcn927y1wyd63la1fhyar9fv1hccsqd23jd98yc55a"))))
(build-system r-build-system)
(propagated-inputs
`(("r-beachmat" ,r-beachmat)
@ -11024,14 +10965,14 @@ quality control.")
(define-public r-scran
(package
(name "r-scran")
(version "1.10.1")
(version "1.10.2")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "scran" version))
(sha256
(base32
"1viyzrwfm9vccsf54c6g7k1dn7skkfx4ml1jy12q67wa20sx8l03"))))
"07mgilr3gq3lnrm1fjm9zhz4w7970bjhsykln1drqy9gkzj5sn7g"))))
(build-system r-build-system)
(propagated-inputs
`(("r-beachmat" ,r-beachmat)
@ -13269,6 +13210,41 @@ descriptive settings file. The result is a set of comprehensive, interactive
HTML reports with interesting findings about your samples.")
(license license:gpl3+)))
(define-public mantis
(let ((commit "4ffd171632c2cb0056a86d709dfd2bf21bc69b84")
(revision "1"))
(package
(name "mantis")
(version (git-version "0" revision commit))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/splatlab/mantis.git")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"0iqbr0dhmlc8mzpirmm2s4pkzkwdgrcx50yx6cv3wlr2qi064p55"))))
(build-system cmake-build-system)
(arguments '(#:tests? #f)) ; there are none
(inputs
`(("sdsl-lite" ,sdsl-lite)
("openssl" ,openssl)
("zlib" ,zlib)))
(home-page "https://github.com/splatlab/mantis")
(synopsis "Large-scale sequence-search index data structure")
(description "Mantis is a space-efficient data structure that can be
used to index thousands of raw-read genomics experiments and facilitate
large-scale sequence searches on those experiments. Mantis uses counting
quotient filters instead of Bloom filters, enabling rapid index builds and
queries, small indexes, and exact results, i.e., no false positives or
negatives. Furthermore, Mantis is also a colored de Bruijn graph
representation, so it supports fast graph traversal and other topological
analyses in addition to large-scale sequence-level searches.")
;; uses __uint128_t and inline assembly
(supported-systems '("x86_64-linux"))
(license license:bsd-3))))
(define-public r-diversitree
(package
(name "r-diversitree")
@ -14166,12 +14142,7 @@ absolute GSEA.")
#:phases
(modify-phases %standard-phases
(delete 'configure)
(replace 'build
(lambda* (#:key inputs outputs #:allow-other-keys)
(substitute* "JAMM.sh"
(("^sPath=.*")
(string-append "")))
#t))
(delete 'build)
(replace 'install
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))

4
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))
@ -264,6 +265,7 @@ maintained upstream.")
(uri (string-append "https://github.com/tatsuhiro-t/aria2/"
"releases/download/release-" version "/"
name "-" version ".tar.xz"))
(patches (search-patches "aria2-CVE-2019-3500.patch"))
(sha256
(base32
"18vpgr430vxlwbcc3598rr1srfmwypls6wp1m4wf21hncc1ahi1s"))))

3
gnu/packages/boost.scm
View File

@ -3,7 +3,7 @@
;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
@ -32,7 +32,6 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system trivial)
#:use-module (gnu packages)

66
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)
@ -364,7 +376,7 @@ tree binary files. These are board description files used by Linux and BSD.")
(define u-boot
(package
(name "u-boot")
(version "2018.11")
(version "2019.01")
(source (origin
(method url-fetch)
(uri (string-append
@ -372,7 +384,7 @@ tree binary files. These are board description files used by Linux and BSD.")
"u-boot-" version ".tar.bz2"))
(sha256
(base32
"0znkwljfwwn4y7j20pzz4ilqw8znphrfxns0x1lwdzh3xbr96z3k"))))
"08hwsmh5xsb1gcxsv8gvx00bai938dm5y3889n8jif3a8rd7xgah"))))
(native-inputs
`(("bc" ,bc)
("bison" ,bison)
@ -428,6 +440,11 @@ also initializes the boards (RAM etc).")
(("def test_ctrl_c")
"@pytest.mark.skip(reason='Guix has problems with SIGINT')
def test_ctrl_c"))
;; This test requires a sound system, which is un-used in u-boot-tools.
(for-each (lambda (file)
(substitute* file
(("CONFIG_SOUND=y") "CONFIG_SOUND=n")))
(find-files "configs" "sandbox_.*defconfig$"))
#t))
(replace 'configure
(lambda* (#:key make-flags #:allow-other-keys)
@ -504,7 +521,7 @@ board-independent tools.")))
(lambda* (#:key outputs make-flags #:allow-other-keys)
(let ((config-name (string-append ,board "_defconfig")))
(if (file-exists? (string-append "configs/" config-name))
(zero? (apply system* "make" `(,@make-flags ,config-name)))
(apply invoke "make" `(,@make-flags ,config-name))
(begin
(display "Invalid board name. Valid board names are:"
(current-error-port))
@ -583,20 +600,7 @@ board-independent tools.")))
(make-u-boot-sunxi64-package "pine64_plus" "aarch64-linux-gnu"))
(define-public u-boot-pinebook
(let ((base (make-u-boot-sunxi64-package "pinebook" "aarch64-linux-gnu")))
(package
(inherit base)
(source (origin
(inherit (package-source u-boot))
(patches (search-patches
;; Add patches to enable Pinebook support from sunxi
;; maintainer tree: git://git.denx.de/u-boot-sunxi.git
"u-boot-pinebook-a64-update-dts.patch"
"u-boot-pinebook-syscon-node.patch"
"u-boot-pinebook-mmc-calibration.patch"
"u-boot-pinebook-video-bridge.patch"
"u-boot-pinebook-r_i2c-controller.patch"
"u-boot-pinebook-dts.patch")))))))
(make-u-boot-sunxi64-package "pinebook" "aarch64-linux-gnu"))
(define-public u-boot-bananapi-m2-ultra
(make-u-boot-package "Bananapi_M2_Ultra" "arm-linux-gnueabihf"))
@ -673,10 +677,25 @@ board-independent tools.")))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"0h0m3l69vp9dr6xrs1p6y7ilkq3jq8jraw2z20kqfv7lvc9l1lxj"))))
"0h0m3l69vp9dr6xrs1p6y7ilkq3jq8jraw2z20kqfv7lvc9l1lxj"))
(patches
(search-patches "vboot-utils-skip-test-workbuf.patch"
"vboot-utils-fix-tests-show-contents.patch"
"vboot-utils-fix-format-load-address.patch"))))
(build-system gnu-build-system)
(arguments
`(#:make-flags (list "CC=gcc"
;; On ARM, we must pass "HOST_ARCH=arm" so that the
;; ${HOST_ARCH} and ${ARCH} variables in the makefile
;; match. Otherwise, ${HOST_ARCH} will be assigned
;; "armv7l", the value of `uname -m`, and will not
;; match ${ARCH}, which will make the tests require
;; QEMU for testing.
,@(if (string-prefix? "arm"
(or (%current-target-system)
(%current-system)))
'("HOST_ARCH=arm")
'())
(string-append "DESTDIR=" (assoc-ref %outputs "out")))
#:phases (modify-phases %standard-phases
(add-after 'unpack 'patch-hard-coded-paths
@ -702,7 +721,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)

1
gnu/packages/bootstrap.scm
View File

@ -187,6 +187,7 @@ or false to signal an error."
;; XXX: This one is used bare-bones, without a libc, so add a case
;; here just so we can keep going.
((string=? system "arm-elf") "no-ld.so")
((string=? system "arm-eabi") "no-ld.so")
((string=? system "xtensa-elf") "no-ld.so")
((string=? system "avr") "no-ld.so")

14
gnu/packages/c.scm
View File

@ -3,6 +3,7 @@
;;; Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Pierre Neidhardt <mail@ambrevar.xyz>
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@ -37,8 +38,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages autotools)
#:use-module (gnu packages gettext)
#:use-module (gnu packages pkg-config)
#:use-module (srfi srfi-1))
#:use-module (gnu packages pkg-config))
(define-public tcc
(package
@ -69,11 +69,15 @@
"/include:{B}/include")
(string-append "--libpaths="
(assoc-ref %build-inputs "libc")
"/lib"))
"/lib")
,@(if (string-prefix? "armhf-linux"
(or (%current-target-system)
(%current-system)))
`("--triplet=arm-linux-gnueabihf")
'()))
#:test-target "test"))
;; Fails to build on MIPS: "Unsupported CPU"
(supported-systems (fold delete %supported-systems
'("mips64el-linux" "aarch64-linux")))
(supported-systems (delete "mips64el-linux" %supported-systems))
(synopsis "Tiny and fast C compiler")
(description
"TCC, also referred to as \"TinyCC\", is a small and fast C compiler

4
gnu/packages/calendar.scm
View File

@ -27,13 +27,11 @@
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system cmake)
#: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)
@ -41,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))

72
gnu/packages/cdrom.scm
View File

@ -11,7 +11,8 @@
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -225,13 +226,32 @@ reconstruction capability.")
(sha256
(base32
"03w6ypsmwwy4d7vh6zgwpc60v541vc5ywp8bdb758hbc4yv2wa7d"))
(modules '((guix build utils)))
(snippet
'(begin
;; By default 'cdda2wav --help' would print a string like
;; "Version 3.01_linux_4.19.10-gnu_x86_64_x86_64". Change
;; it to not capture the kernel version of the build
;; machine, to allow for reproducible builds.
(substitute* "cdda2wav/local.cnf.in"
(("^VERSION_OS=.*")
(string-append
"actual_os := $(shell uname -o)\n"
"actual_arch := $(shell uname -m)\n"
"VERSION_OS = _$(actual_os)_$(actual_arch)\n")))
#t))
(patches (search-patches "cdrtools-3.01-mkisofs-isoinfo.patch"))))
(build-system gnu-build-system)
;; XXX cdrtools bundles a modified, relicensed early version of cdparanoia.
(inputs
`(("linux-headers" ,linux-libre-headers)))
(arguments
`(#:phases
`(#:make-flags
(list "RM=rm" "LN=ln" "SYMLINK=ln -s"
"CONFIG_SHELL=sh" "CCOM=gcc"
(string-append "INS_BASE=" (assoc-ref %outputs "out"))
(string-append "INS_RBASE=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
(delete 'configure)
(add-before 'build 'set-linux-headers
@ -246,19 +266,7 @@ reconstruction capability.")
(find-files "DEFAULTS_ENG" "^Defaults\\.")
(find-files "TEMPLATES" "^Defaults\\."))
(("/opt/schily") (assoc-ref %outputs "out")))
#t))
(replace 'build
(lambda _
(zero?
(system* "make" "CONFIG_SHELL=sh" "CCOM=gcc" "RM=rm"))))
(replace 'install
(lambda _
(zero?
(system* "make"
"RM=rm" "LN=ln" "SYMLINK=ln -s"
(string-append "INS_BASE=" (assoc-ref %outputs "out"))
(string-append "INS_RBASE=" (assoc-ref %outputs "out"))
"install" )))))
#t)))
#:tests? #f)) ; no tests
(synopsis "Command line utilities to manipulate and burn CD/DVD/BD images")
(description "cdrtools is a collection of command line utilities to create
@ -343,7 +351,36 @@ or @command{xorrisofs} to create ISO 9660 images.")
`(;; Parallel builds appear to be unsafe, see
;; <http://hydra.gnu.org/build/49331/nixlog/1/raw>.
#:parallel-build? #f
#:tests? #f)) ; no check target
#:phases
(modify-phases %standard-phases
(replace 'check
(lambda _
(with-directory-excursion "regtest"
(substitute* "common.bash"
(("ISODIR=/var/tmp/regtest") "ISODIR=/tmp"))
(for-each invoke (find-files "." "rs.*\\.bash")))
#t))
(add-after 'install 'install-desktop
(lambda* (#:key outputs #:allow-other-keys)
(let* ((datadir (string-append (assoc-ref outputs "out") "/share")))
(substitute* "contrib/dvdisaster.desktop"
(("dvdisaster48.png") "dvdisaster.png"))
(install-file "contrib/dvdisaster.desktop"
(string-append datadir "/applications"))
(for-each
(lambda (png)
(let* ((size (substring png
(string-index png char-set:digit)
(string-rindex png #\.)))
(icondir (string-append datadir "/icons/"
size "x" size "/apps")))
(mkdir-p icondir)
(copy-file png (string-append icondir "/dvdisaster.png"))))
(find-files "contrib" "dvdisaster[0-9]*\\.png"))
(mkdir-p (string-append datadir "/pixmaps"))
(copy-file "contrib/dvdisaster48.xpm"
(string-append datadir "/pixmaps/dvdisaster.xpm"))
#t))))))
(home-page "http://dvdisaster.net/en/index.html")
(synopsis "Error correcting codes for optical media images")
(description "Optical media (CD,DVD,BD) keep their data only for a
@ -558,7 +595,8 @@ from an audio CD.")
(for-each wrap
(find-files (string-append out "/bin")
".*"))))))
".*")))
#t)))
#:tests? #f)) ; no test target
(inputs `(("wget" ,wget)

154
gnu/packages/check.scm
View File

@ -7,7 +7,7 @@
;;; Copyright © 2015, 2017 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015, 2016, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2015, 2016, 2018, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Danny Milosavljevic <dannym+a@scratchpost.org>
@ -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:)
@ -210,12 +217,14 @@ multi-paradigm automated test framework for C++ and Objective-C.")
(version "1.12.2")
(home-page "https://github.com/catchorg/Catch2")
(source (origin
(method url-fetch)
(uri (string-append home-page "/archive/v" version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://github.com/catchorg/Catch2")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0g2ysxc6adqca5wh7nsicnxb9wkxg75cd5izjsl39rcj0v903gr7"))
(file-name (string-append name "-" version ".tar.gz"))))
"1gdp5wm8khn02g2miz381llw3191k7309qj8s3jd6sasj01rhf23"))))
(build-system cmake-build-system)
(synopsis "Automated test framework for C++ and Objective-C")
(description "Catch2 stands for C++ Automated Test Cases in Headers and is
@ -294,15 +303,18 @@ format.")
(define-public cppcheck
(package
(name "cppcheck")
(version "1.85")
(version "1.86")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/danmar/cppcheck/archive/"
version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://github.com/danmar/cppcheck")
(commit version)))
(file-name (git-file-name name version))
(sha256
(base32 "18qlddf1i9bk5nnvy1v2nfxjd46y8wvp3rqz2hrfxjxsyvrfq5yw"))
(file-name (string-append name "-" version ".tar.gz"))))
(base32 "0jr4aah72c7wy94a8vlj3k050rx6pmc7m9nvmll1jwbscxj5f7ff"))))
(build-system cmake-build-system)
(arguments
'(#:configure-flags '("-DBUILD_TESTS=ON")))
(home-page "http://cppcheck.sourceforge.net")
(synopsis "Static C/C++ code analyzer")
(description "Cppcheck is a static code analyzer for C and C++. Unlike
@ -699,14 +711,14 @@ and many external plugins.")
(define-public python-pytest-cov
(package
(name "python-pytest-cov")
(version "2.5.1")
(version "2.6.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "pytest-cov" version))
(sha256
(base32
"0bbfpwdh9k3636bxc88vz9fa7vf4akchgn513ql1vd0xy4n7bah3"))))
"0qnpp9y3ygx4jk4pf5ad71fh2skbvnr6gl54m7rg5qysnx4g0q73"))))
(build-system python-build-system)
(arguments
`(#:phases
@ -795,14 +807,14 @@ same arguments.")
(define-public python-pytest-xdist
(package
(name "python-pytest-xdist")
(version "1.14")
(version "1.25.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "pytest-xdist" version ".zip"))
(uri (pypi-uri "pytest-xdist" version))
(sha256
(base32
"08rn2l39ds60xshs4js787l84pfckksqklfq2wq9x8ig2aci2pja"))
"1d812apvcmshh2l8f38spqwb3bpp0x43yy7lyfpxxzc99h4r7y4n"))
(modules '((guix build utils)))
(snippet
'(begin
@ -822,8 +834,7 @@ same arguments.")
;; (add-installed-pythonpath inputs outputs)
;; (zero? (system* "py.test" "-v")))))
(native-inputs
`(("unzip" ,unzip)
("python-setuptools-scm" ,python-setuptools-scm)))
`(("python-setuptools-scm" ,python-setuptools-scm)))
(propagated-inputs
`(("python-execnet" ,python-execnet)
("python-pytest" ,python-pytest)
@ -851,9 +862,7 @@ result back.")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/s/scripttest/scripttest-"
version ".tar.gz"))
(uri (pypi-uri "scripttest" version))
(sha256
(base32
"0f4w84k8ck82syys7yg9maz93mqzc8p5ymis941x034v44jzq74m"))))
@ -1021,14 +1030,14 @@ use of resources by test cases.")))
(define-public python-subunit-bootstrap
(package
(name "python-subunit-bootstrap")
(version "1.2.0")
(version "1.3.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "python-subunit" version))
(sha256
(base32
"1yii2gx3z6323as3iraj1yphj76dy7i3h6kj63pnc5y0hwjs5sgx"))))
"1fsw8rsn1s3nklx06mayrg5rn2zbky6wwjc5z07s7rf1wjzfs1wn"))))
(build-system python-build-system)
(propagated-inputs
`(("python-extras" ,python-extras)
@ -1037,7 +1046,7 @@ use of resources by test cases.")))
`(("python-fixtures" ,python-fixtures-bootstrap)
("python-hypothesis" ,python-hypothesis)
("python-testscenarios" ,python-testscenarios-bootstrap)))
(home-page "http://launchpad.net/subunit")
(home-page "https://launchpad.net/subunit")
(synopsis "Python implementation of the subunit protocol")
(description
"This package is here for bootstrapping purposes only. Use the regular
@ -1124,9 +1133,7 @@ Python tests.")))
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/t/testrepository/testrepository-"
version ".tar.gz"))
(uri (pypi-uri "testrepository" version))
(sha256
(base32
"1ssqb07c277010i6gzzkbdd46gd9mrj0bi0i8vn560n2k2y4j93m"))))
@ -1249,13 +1256,14 @@ C/C++, R, and more, and uploads it to the @code{codecov.io} service.")
(version "0.2")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/jupyter/testpath/archive/"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://github.com/jupyter/testpath")
(commit version)))
(file-name (git-file-name name version))
(sha256
(base32
"04kh3fgvmqz6cfcw79q70qwjz7ib7lxm27cc548iy2rpr33qqf55"))))
"0r4iiizjql6ny1ln7ciw7rrbjadz1s9zrf2hl0xkgnh3ypd8936f"))))
(build-system python-build-system)
(arguments
`(#:tests? #f ; this package does not even have a setup.py
@ -1297,9 +1305,7 @@ tools for mocking system commands and recording calls to those.")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/t/testlib/testlib-"
version ".zip"))
(uri (pypi-uri "testlib" version ".zip"))
(sha256
(base32 "1mz26cxn4x8bbgv0rn0mvj2z05y31rkc8009nvdlb3lam5b4mj3y"))))
(build-system python-build-system)
@ -1796,9 +1802,7 @@ especially -cover-package.")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/d/discover/discover-"
version ".tar.gz"))
(uri (pypi-uri "discover" version))
(sha256
(base32
"0y8d0zwiqar51kxj8lzmkvwc3b8kazb04gk5zcb4nzg5k68zmhq5"))))
@ -2029,13 +2033,13 @@ mocks, stubs and fakes.")
(define-public python-flaky
(package
(name "python-flaky")
(version "3.4.0")
(version "3.5.3")
(source (origin
(method url-fetch)
(uri (pypi-uri "flaky" version))
(sha256
(base32
"18pkmf79rfkfpy1d2rrx3v55nxj762ilyk9rvd6s6dccxw58imsa"))))
"1nm1kjf857z5aw7v642ffsy1vwf255c6wjvmil71kckjyd0mxg8j"))))
(build-system python-build-system)
(arguments
;; TODO: Tests require 'coveralls' and 'genty' which are not in Guix yet.
@ -2060,17 +2064,15 @@ retried.")
(name "python-pyhamcrest")
(version "1.9.0")
(source (origin
(method url-fetch)
(uri
(string-append
"https://github.com/hamcrest/PyHamcrest/archive/V"
version
".tar.gz"))
(file-name
(string-append name "-" version ".tar.gz"))
;; Tests not distributed from pypi release.
(method git-fetch)
(uri (git-reference
(url "https://github.com/hamcrest/PyHamcrest")
(commit (string-append "V" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1lqjajhwf7x7igvvnj5p1cm31y9njy07qby94w18kl6zwbdjqrwy"))))
"01qnzj9qnzz0y78qa3ing24ssvszb0adw59xc4qqmdn5wryy606b"))))
(native-inputs ; All native inputs are for tests
`(("python-pytest-cov" ,python-pytest-cov)
("python-mock" ,python-mock)
@ -2094,13 +2096,13 @@ retried.")
(name "unittest-cpp")
(version "2.0.0")
(source (origin
(method url-fetch)
(uri (string-append
"https://github.com/unittest-cpp/unittest-cpp/archive/v"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://github.com/unittest-cpp/unittest-cpp")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32 "1fgmna2la7z4pwwy2gd10gpgi2q1fk89npjfvkmzvhkxhyc231bl"))))
(base32 "0sxb3835nly1jxn071f59fwbdzmqi74j040r81fanxyw3s1azw0i"))))
(arguments
`(#:tests? #f)) ; It's run after build automatically.
(build-system cmake-build-system)
@ -2152,3 +2154,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)

2
gnu/packages/ci.scm
View File

@ -32,10 +32,12 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages databases)
#:use-module (gnu packages guile)
#:use-module (gnu packages guile-xyz)
#:use-module (gnu packages gnupg)
#: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)

19
gnu/packages/clojure.scm
View File

@ -65,15 +65,16 @@
(package
(name "clojure")
(version "1.9.0")
(source
(origin
(method url-fetch)
(uri
(string-append "https://github.com/clojure/clojure/archive/clojure-"
version ".tar.gz"))
(sha256
(base32 "0xjbzcw45z32vsn9pifp7ndysjzqswp5ig0jkjpivigh2ckkdzha"))))
(version "1.10.0")
(source (let ((name+version (string-append name "-" version)))
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/clojure/clojure")
(commit name+version)))
(file-name (string-append name+version "-checkout"))
(sha256
(base32 "1kcyv2836acs27vi75hvf3r773ahv2nlh9b3j9xa9m9sdanz1h83")))))
(build-system ant-build-system)
(arguments
`(#:imported-modules ((guix build clojure-utils)

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

13
gnu/packages/code.scm
View File

@ -2,7 +2,7 @@
;;; Copyright © 2013, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016, 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016, 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Andy Wingo <wingo@igalia.com>
@ -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)
@ -113,14 +113,14 @@ highlighting your own code that seemed comprehensible when you wrote it.")
(define-public global ; a global variable
(package
(name "global")
(version "6.6.2")
(version "6.6.3")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/global/global-"
version ".tar.gz"))
(sha256
(base32
"0zvi5vxwiq0dy8mq2cgs64m8harxs0fvkmsnvi0ayb0w608lgij3"))))
"0735pj47dnspf20n0j1px24p59nwjinlmlb2n32ln1hvdkprivnb"))))
(build-system gnu-build-system)
(inputs `(("ncurses" ,ncurses)
("libltdl" ,libltdl)
@ -186,14 +186,15 @@ around in a large, deeply nested project.")
(mkdir-p (string-append out
"/share/man/man1"))
(mkdir-p (string-append out
"/share/doc")))))
"/share/doc"))
#t)))
(replace 'check
(lambda _
(setenv "HOME" (getcwd))
(setenv "PATH"
(string-append (getcwd) ":"
(getenv "PATH")))
(zero? (system* "make" "test")))))
(invoke "make" "test"))))
#:make-flags (list (string-append "PREFIX="
(assoc-ref %outputs "out")))))

607
gnu/packages/compression.scm
View File

@ -12,7 +12,7 @@
;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2016, 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 Kei Kebreau <kkebreau@posteo.net>
;;; Copyright © 2016, 2019 Kei Kebreau <kkebreau@posteo.net>
;;; Copyright © 2016, 2018 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
@ -45,11 +45,8 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build-system ant)
#: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)
@ -59,10 +56,8 @@
#:use-module (gnu packages check)
#:use-module (gnu packages curl)
#:use-module (gnu packages file)
#:use-module (gnu packages java)
#: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)
@ -456,6 +451,39 @@ than gzip and 15 % smaller output than bzip2.")
(license (list license:gpl2+ license:lgpl2.1+)) ; bits of both
(home-page "https://tukaani.org/xz/")))
(define-public lhasa
(package
(name "lhasa")
(version "0.3.1")
(source (origin
(method url-fetch)
(uri (string-append
"https://github.com/fragglet/lhasa/releases/download/v"
version "/lhasa-" version ".tar.gz"))
(sha256
(base32
"092zi9av18ma20c6h9448k0bapvx2plnp292741dvfd9hmgqxc1z"))))
(build-system gnu-build-system)
(arguments
'(#:phases
(modify-phases %standard-phases
(add-before 'check 'set-up-test-environment
(lambda* (#:key inputs #:allow-other-keys)
(setenv "TZDIR" (string-append (assoc-ref inputs "tzdata")
"/share/zoneinfo"))
#t)))))
(native-inputs
`(("tzdata" ,tzdata)))
(home-page "https://fragglet.github.com/lhasa/")
(synopsis "LHA archive decompressor")
(description "Lhasa is a replacement for the Unix LHA tool, for
decompressing .lzh (LHA / LHarc) and .lzs (LArc) archives. The backend for the
tool is a library, so that it can be reused for other purposes. Lhasa aims to
be compatible with as many types of lzh/lzs archives as possible. It also aims
to generate the same output as the (non-free) Unix LHA tool, so that it will
act as a free drop-in replacement.")
(license license:isc)))
(define-public lzo
(package
(name "lzo")
@ -482,44 +510,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")
@ -729,84 +719,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")
@ -839,54 +751,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")
@ -1216,46 +1080,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")
@ -1282,282 +1106,6 @@ for most inputs, but the resulting compressed files are anywhere from 20% to
100% bigger.")
(license license:asl2.0)))
(define bitshuffle-for-snappy
(package
(inherit bitshuffle)
(name "bitshuffle-for-snappy")
(build-system gnu-build-system)
(arguments
`(#:tests? #f
#: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 java-snappy
(package
(name "java-snappy")
(version "1.1.7.2")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/xerial/snappy-java/archive/"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"1p557vdv006ysgxbpp83krmq0066k46108vyiyka69w8i4i8rbbm"))))
(build-system ant-build-system)
(arguments
`(#:jar-name "snappy.jar"
#:source-dir "src/main/java"
#:phases
(modify-phases %standard-phases
(add-before 'build 'remove-binaries
(lambda _
(delete-file "lib/org/xerial/snappy/OSInfo.class")
(delete-file-recursively "src/main/resources/org/xerial/snappy/native")
#t))
(add-before 'build 'build-jni
(lambda _
;; Rebuild one of the binaries we removed earlier
(invoke "javac" "src/main/java/org/xerial/snappy/OSInfo.java"
"-d" "lib")
;; Link to the dynamic bitshuffle and snappy, not the static ones
(substitute* "Makefile.common"
(("-shared")
"-shared -lbitshuffle -lsnappy"))
(substitute* "Makefile"
;; Don't try to use git, don't download bitshuffle source
;; and don't build it.
(("\\$\\(SNAPPY_GIT_UNPACKED\\) ")
"")
((": \\$\\(SNAPPY_GIT_UNPACKED\\)")
":")
(("\\$\\(BITSHUFFLE_UNPACKED\\) ")
"")
((": \\$\\(SNAPPY_SOURCE_CONFIGURED\\)") ":")
;; What we actually want to build
(("SNAPPY_OBJ:=.*")
"SNAPPY_OBJ:=$(addprefix $(SNAPPY_OUT)/, \
SnappyNative.o BitShuffleNative.o)\n")
;; Since we removed the directory structure in "native" during
;; the previous phase, we need to recreate it.
(("NAME\\): \\$\\(SNAPPY_OBJ\\)")
"NAME): $(SNAPPY_OBJ)\n\t@mkdir -p $(@D)"))
;; Finally we can run the Makefile to build the dynamic library.
;; Use the -nocmake target to avoid a dependency on cmake,
;; which in turn requires the "git_unpacked" directory.
(invoke "make" "native-nocmake")))
;; Once we have built the shared library, we need to place it in the
;; "build" directory so it can be added to the jar file.
(add-after 'build-jni 'copy-jni
(lambda _
(copy-recursively "src/main/resources/org/xerial/snappy/native"
"build/classes/org/xerial/snappy/native")
#t))
(add-before 'check 'fix-failing
(lambda _
(with-directory-excursion "src/test/java/org/xerial/snappy"
;; This package assumes maven build, which puts results in "target".
;; We put them in "build" instead, so fix that.
(substitute* "SnappyLoaderTest.java"
(("target/classes") "build/classes"))
;; This requires Hadoop, which is not in Guix yet.
(delete-file "SnappyHadoopCompatibleOutputStreamTest.java"))
#t)))))
(inputs
`(("osgi-framework" ,java-osgi-framework)))
(propagated-inputs
`(("bitshuffle" ,bitshuffle-for-snappy)
("snappy" ,snappy)))
(native-inputs
`(("junit" ,java-junit)
("hamcrest" ,java-hamcrest-core)
("xerial-core" ,java-xerial-core)
("classworlds" ,java-plexus-classworlds)
("commons-lang" ,java-commons-lang)
("commons-io" ,java-commons-io)
("perl" ,perl)))
(home-page "https://github.com/xerial/snappy-java")
(synopsis "Compression/decompression algorithm in Java")
(description "Snappy-java is a Java port of snappy, a fast C++
compressor/decompressor.")
(license license:asl2.0)))
(define-public java-snappy-1
(package
(inherit java-snappy)
(version "1.0.3-rc3")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/xerial/snappy-java/archive/"
"snappy-java-" version ".tar.gz"))
(sha256
(base32
"08hsxlqidiqck0q57fshwyv3ynyxy18vmhrai9fyc8mz17m7gsa3"))))
(arguments
`(#:jar-name "snappy.jar"
#:source-dir "src/main/java"
#:phases
(modify-phases %standard-phases
(add-before 'build 'remove-binaries
(lambda _
(delete-file "lib/org/xerial/snappy/OSInfo.class")
(delete-file-recursively "src/main/resources/org/xerial/snappy/native")
#t))
(add-before 'build 'build-jni
(lambda _
;; Rebuild one of the binaries we removed earlier
(invoke "javac" "src/main/java/org/xerial/snappy/OSInfo.java"
"-d" "lib")
;; Link to the dynamic snappy, not the static ones
(substitute* "Makefile.common"
(("-shared") "-shared -lsnappy"))
(substitute* "Makefile"
;; Don't download the sources here.
(("\\$\\(SNAPPY_UNPACKED\\) ") "")
((": \\$\\(SNAPPY_UNPACKED\\) ") ":")
;; What we actually want to build
(("SNAPPY_OBJ:=.*")
"SNAPPY_OBJ:=$(addprefix $(SNAPPY_OUT)/, SnappyNative.o)\n")
;; Since we removed the directory structure in "native" during
;; the previous phase, we need to recreate it.
(("NAME\\): \\$\\(SNAPPY_OBJ\\)")
"NAME): $(SNAPPY_OBJ)\n\t@mkdir -p $(@D)"))
;; Finally we can run the Makefile to build the dynamic library.
(invoke "make" "native")))
;; Once we have built the shared library, we need to place it in the
;; "build" directory so it can be added to the jar file.
(add-after 'build-jni 'copy-jni
(lambda _
(copy-recursively "src/main/resources/org/xerial/snappy/native"
"build/classes/org/xerial/snappy/native")
#t))
(add-before 'check 'fix-tests
(lambda _
(mkdir-p "src/test/resources/org/xerial/snappy/")
(copy-recursively "src/test/java/org/xerial/snappy/testdata"
"src/test/resources/org/xerial/snappy/testdata")
(install-file "src/test/java/org/xerial/snappy/alice29.txt"
"src/test/resources/org/xerial/snappy/")
#t)))))))
(define-public java-iq80-snappy
(package
(name "java-iq80-snappy")
(version "0.4")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/dain/snappy/archive/snappy-"
version ".tar.gz"))
(sha256
(base32
"0rb3zhci7w9wzd65lfnk7p3ip0n6gb58a9qpx8n7r0231gahyamf"))))
(build-system ant-build-system)
(arguments
`(#:jar-name "iq80-snappy.jar"
#:source-dir "src/main/java"
#:test-dir "src/test"
#:jdk ,icedtea-8
#:phases
(modify-phases %standard-phases
(replace 'check
(lambda _
(define (test class)
(invoke "java" "-cp" (string-append (getenv "CLASSPATH")
":build/classes"
":build/test-classes")
"-Dtest.resources.dir=src/test/resources"
"org.testng.TestNG" "-testclass"
class))
(invoke "ant" "compile-tests")
(test "org.iq80.snappy.SnappyFramedStreamTest")
(test "org.iq80.snappy.SnappyStreamTest")
#t))
(add-before 'build 'remove-hadoop-dependency
(lambda _
;; We don't have hadoop
(delete-file "src/main/java/org/iq80/snappy/HadoopSnappyCodec.java")
(delete-file "src/test/java/org/iq80/snappy/TestHadoopSnappyCodec.java")
#t)))))
(home-page "https://github.com/dain/snappy")
(native-inputs
`(("guava" ,java-guava)
("java-snappy" ,java-snappy)
("hamcrest" ,java-hamcrest-core)
("testng" ,java-testng)))
(synopsis "Java port of the Snappy (de)compressor")
(description
"Iq80-snappy is a port of the Snappy compressor and decompressor rewritten
in pure Java. This compression code produces a byte-for-byte exact copy of the
output created by the original C++ code, and is extremely fast.")
(license license:asl2.0)))
(define-public java-jbzip2
(package
(name "java-jbzip2")
(version "0.9.1")
(source (origin
(method url-fetch)
(uri (string-append "https://storage.googleapis.com/"
"google-code-archive-source/v2/"
"code.google.com/jbzip2/"
"source-archive.zip"))
(file-name (string-append name "-" version ".zip"))
(sha256
(base32
"0ncmhlqmrfmj96nqf6p77b9ws35lcfsvpfxzwxi2asissc83z1l3"))))
(build-system ant-build-system)
(native-inputs
`(("unzip" ,unzip)
("java-junit" ,java-junit)))
(arguments
`(#:tests? #f ; no tests
#:jar-name "jbzip2.jar"
#:source-dir "tags/release-0.9.1/src"
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'fix-encoding-problems
(lambda _
;; Some of the files we're patching are
;; ISO-8859-1-encoded, so choose it as the default
;; encoding so the byte encoding is preserved.
(with-fluids ((%default-port-encoding #f))
(substitute* "tags/release-0.9.1/src/org/itadaki/bzip2/HuffmanAllocator.java"
(("Milidi.") "Milidiu")))
#t)))))
(home-page "https://code.google.com/archive/p/jbzip2/")
(synopsis "Java bzip2 compression/decompression library")
(description "Jbzip2 is a Java bzip2 compression/decompression library.
It can be used as a replacement for the Apache @code{CBZip2InputStream} /
@code{CBZip2OutputStream} classes.")
(license license:expat)))
(define-public p7zip
(package
(name "p7zip")
@ -1803,14 +1351,14 @@ or junctions, and always follows hard links.")
(define-public zstd
(package
(name "zstd")
(version "1.3.7")
(version "1.3.8")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/facebook/zstd/releases/download/"
"v" version "/zstd-" version ".tar.gz"))
(sha256
(base32 "0gapsdzqfsfqqddzv22592iwa0008xjyi15f06pfv9hcvwvg4xrj"))))
(base32 "13nlsqhkn276frxrzjdn7wz0j9zz414lf336885ykyxcvw2a0gr9"))))
(build-system gnu-build-system)
(arguments
`(#:phases
@ -1825,7 +1373,7 @@ or junctions, and always follows hard links.")
;; Not currently detected, but be explicit & avoid surprises later.
"HAVE_LZ4=0"
"HAVE_ZLIB=0")))
(home-page "http://zstd.net/")
(home-page "https://facebook.github.io/zstd/")
(synopsis "Zstandard real-time compression algorithm")
(description "Zstandard (@command{zstd}) is a lossless compression algorithm
that combines very fast operation with a compression ratio comparable to that of
@ -2012,29 +1560,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.60")
(source
(origin
(method url-fetch)
(uri (string-append
"mirror://cpan/authors/id/P/PH/PHRED/Archive-Zip-"
version ".tar.gz"))
(sha256
(base32
"02y2ylq83hy9kgj57sc0239x65br9sm98c0chsm61s08yc2mpiza"))))
(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")
@ -2095,64 +1620,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 java-tukaani-xz
(package
(name "java-tukaani-xz")
(version "1.6")
(source (origin
(method url-fetch)
(uri (string-append "https://tukaani.org/xz/xz-java-" version ".zip"))
(sha256
(base32
"1z3p1ri1gvl07inxn0agx44ck8n7wrzfmvkz8nbq3njn8r9wba8x"))))
(build-system ant-build-system)
(arguments
`(#:tests? #f; no tests
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'chdir
(lambda _
;; Our build system enters the first directory in the archive, but
;; the package is not contained in a subdirectory
(chdir "..")
#t))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
;; Do we want to install *Demo.jar?
(install-file "build/jar/xz.jar"
(string-append
(assoc-ref outputs "out")
"/share/java/xz.jar"))
#t)))))
(native-inputs
`(("unzip" ,unzip)))
(home-page "https://tukaani.org")
(synopsis "XZ in Java")
(description "Tukaani-xz is an implementation of xz compression/decompression
algorithms in Java.")
(license license:public-domain)))
(define-public lunzip
(package
(name "lunzip")

83
gnu/packages/conkeror.scm
View File

@ -1,83 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com>
;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 John J. Foerch <jjfoerch@earthlink.net>
;;;
;;; 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 conkeror)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages gnuzilla))
(define-public conkeror
(package
(name "conkeror")
(version "1.1.0")
(source (origin
(method url-fetch)
(uri
(string-append "http://repo.or.cz/conkeror.git/snapshot/"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0jz216mjwis7f03j98s4wkcrrq2j3f41fb2y47a5qszc340zhdzv"))))
(build-system gnu-build-system)
(inputs `(("icecat" ,icecat)))
(arguments
`(#:tests? #f ;no tests
#:make-flags `("CC=gcc"
,(string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
(delete 'configure)
(add-after
'install 'install-app-launcher
(lambda* (#:key inputs outputs #:allow-other-keys)
;; This overwrites the installed launcher, which execs xulrunner,
;; with one that execs 'icecat --app'
(let* ((out (assoc-ref outputs "out"))
(datadir (string-append out "/share/conkeror"))
(launcher (string-append out "/bin/conkeror")))
(call-with-output-file launcher
(lambda (p)
(format p "#!~a/bin/bash
exec ~a/bin/icecat --app ~a \"$@\"~%"
(assoc-ref inputs "bash") ;implicit input
(assoc-ref inputs "icecat")
(string-append datadir
"/application.ini"))))
(chmod launcher #o555)))))))
(synopsis "Keyboard focused web browser with Emacs look and feel")
(description "Conkeror is a highly-programmable web browser based on
Mozilla XULRunner which is the base of all Mozilla products including Firefox.
Conkeror has a sophisticated keyboard system for running commands and
interacting with web page content, modelled after Emacs and Lynx. It is
self-documenting and extensible with JavaScript.
It comes with builtin support for several Web 2.0 sites like several Google
services (Search, Gmail, Maps, Reader, etc.), Del.icio.us, Reddit, Last.fm and
YouTube. For easier editing of form fields, it can spawn external editors.")
(home-page "http://conkeror.org")
;; Conkeror is triple licensed.
(license (list
;; MPL 1.1 -- this license is not GPL compatible
license:gpl2
license:lgpl2.1))))

8
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)
@ -159,10 +160,9 @@ sharing) to clients via USB, ethernet, WiFi, cellular and Bluetooth.")
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(zero?
(system* "qmake"
(string-append "PREFIX="
(assoc-ref outputs "out"))))))
(invoke "qmake"
(string-append "PREFIX="
(assoc-ref outputs "out")))))
(add-before 'install 'fix-Makefiles
(lambda* (#:key inputs outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))

446
gnu/packages/coq.scm Normal file
View File

@ -0,0 +1,446 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 coq)
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bison)
#:use-module (gnu packages boost)
#:use-module (gnu packages emacs)
#:use-module (gnu packages flex)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages ocaml)
#:use-module (gnu packages perl)
#:use-module (gnu packages python)
#:use-module (gnu packages texinfo)
#:use-module (guix build-system gnu)
#:use-module (guix build-system ocaml)
#:use-module (guix download)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module ((srfi srfi-1) #:hide (zip)))
(define-public coq
(package
(name "coq")
(version "8.8.2")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/coq/coq/archive/V"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0i2hs0i6rp27cy8zd0mx7jscqw5cx2y0diw0pxgij66s3yr47y7r"))))
(native-search-paths
(list (search-path-specification
(variable "COQPATH")
(files (list "lib/coq/user-contrib")))))
(build-system ocaml-build-system)
(inputs
`(("lablgtk" ,lablgtk)
("python" ,python-2)
("camlp5" ,camlp5)
("ocaml-num" ,ocaml-num)))
(arguments
`(#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(mandir (string-append out "/share/man"))
(browser "icecat -remote \"OpenURL(%s,new-tab)\""))
(invoke "./configure"
"-prefix" out
"-mandir" mandir
"-browser" browser
"-coqide" "opt"))))
(replace 'build
(lambda _
(invoke "make"
"-j" (number->string (parallel-job-count))
"world")))
(delete 'check)
(add-after 'install 'check
(lambda _
(with-directory-excursion "test-suite"
;; These two tests fail.
;; This one fails because the output is not formatted as expected.
(delete-file-recursively "coq-makefile/timing")
;; This one fails because we didn't build coqtop.byte.
(delete-file-recursively "coq-makefile/findlib-package")
(invoke "make")))))))
(home-page "https://coq.inria.fr")
(synopsis "Proof assistant for higher-order logic")
(description
"Coq is a proof assistant for higher-order logic, which allows the
development of computer programs consistent with their formal specification.
It is developed using Objective Caml and Camlp5.")
;; The code is distributed under lgpl2.1.
;; Some of the documentation is distributed under opl1.0+.
(license (list license:lgpl2.1 license:opl1.0+))))
(define-public proof-general
(package
(name "proof-general")
(version "4.2")
(source (origin
(method url-fetch)
(uri (string-append
"http://proofgeneral.inf.ed.ac.uk/releases/"
"ProofGeneral-" version ".tgz"))
(sha256
(base32
"09qb0myq66fw17v4ziz401ilsb5xlxz1nl2wsp69d0vrfy0bcrrm"))))
(build-system gnu-build-system)
(native-inputs
`(("which" ,which)
("emacs" ,emacs-minimal)
("texinfo" ,texinfo)))
(inputs
`(("host-emacs" ,emacs)
("perl" ,perl)
("coq" ,coq)))
(arguments
`(#:tests? #f ; no check target
#:make-flags (list (string-append "PREFIX=" %output)
(string-append "DEST_PREFIX=" %output))
#:modules ((guix build gnu-build-system)
(guix build utils)
(guix build emacs-utils))
#:imported-modules (,@%gnu-build-system-modules
(guix build emacs-utils))
#:phases
(modify-phases %standard-phases
(delete 'configure)
(add-after 'unpack 'disable-byte-compile-error-on-warn
(lambda _
(substitute* "Makefile"
(("\\(setq byte-compile-error-on-warn t\\)")
"(setq byte-compile-error-on-warn nil)"))
#t))
(add-after 'unpack 'patch-hardcoded-paths
(lambda* (#:key inputs outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(coq (assoc-ref inputs "coq"))
(emacs (assoc-ref inputs "host-emacs")))
(define (coq-prog name)
(string-append coq "/bin/" name))
(emacs-substitute-variables "coq/coq.el"
("coq-prog-name" (coq-prog "coqtop"))
("coq-compiler" (coq-prog "coqc"))
("coq-dependency-analyzer" (coq-prog "coqdep")))
(substitute* "Makefile"
(("/sbin/install-info") "install-info"))
(substitute* "bin/proofgeneral"
(("^PGHOMEDEFAULT=.*" all)
(string-append all
"PGHOME=$PGHOMEDEFAULT\n"
"EMACS=" emacs "/bin/emacs")))
#t)))
(add-after 'unpack 'clean
(lambda _
;; Delete the pre-compiled elc files for Emacs 23.
(invoke "make" "clean")))
(add-after 'install 'install-doc
(lambda* (#:key make-flags #:allow-other-keys)
;; XXX FIXME avoid building/installing pdf files,
;; due to unresolved errors building them.
(substitute* "Makefile"
((" [^ ]*\\.pdf") ""))
(apply invoke "make" "install-doc" make-flags))))))
(home-page "http://proofgeneral.inf.ed.ac.uk/")
(synopsis "Generic front-end for proof assistants based on Emacs")
(description
"Proof General is a major mode to turn Emacs into an interactive proof
assistant to write formal mathematical proofs using a variety of theorem
provers.")
(license license:gpl2+)))
(define-public coq-flocq
(package
(name "coq-flocq")
(version "2.6.1")
(source (origin
(method url-fetch)
;; Use the ‘Latest version’ link for a stable URI across releases.
(uri (string-append "https://gforge.inria.fr/frs/download.php/"
"file/37454/flocq-" version ".tar.gz"))
(sha256
(base32
"06msp1fwpqv6p98a3i1nnkj7ch9rcq3rm916yxq8dxf51lkghrin"))))
(build-system gnu-build-system)
(native-inputs
`(("ocaml" ,ocaml)
("which" ,which)
("coq" ,coq)))
(arguments
`(#:configure-flags
(list (string-append "--libdir=" (assoc-ref %outputs "out")
"/lib/coq/user-contrib/Flocq"))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'fix-remake
(lambda _
(substitute* "remake.cpp"
(("/bin/sh") (which "sh")))
#t))
(replace 'build
(lambda _
(invoke "./remake")
#t))
(replace 'check
(lambda _
(invoke "./remake" "check")
#t))
;; TODO: requires coq-gappa and coq-interval.
;(invoke "./remake" "check-more")
(replace 'install
(lambda _
(invoke "./remake" "install")
#t)))))
(home-page "http://flocq.gforge.inria.fr/")
(synopsis "Floating-point formalization for the Coq system")
(description "Flocq (Floats for Coq) is a floating-point formalization for
the Coq system. It provides a comprehensive library of theorems on a multi-radix
multi-precision arithmetic. It also supports efficient numerical computations
inside Coq.")
(license license:lgpl3+)))
(define-public coq-gappa
(package
(name "coq-gappa")
(version "1.3.2")
(source (origin
(method url-fetch)
(uri (string-append "https://gforge.inria.fr/frs/download.php/file/36397/gappa-"
version ".tar.gz"))
(sha256
(base32
"19kg2zldaqs4smy7bv9hp650sqg46xbx1ss7jnyagpxdscwn9apd"))))
(build-system gnu-build-system)
(native-inputs
`(("ocaml" ,ocaml)
("which" ,which)
("coq" ,coq)
("bison" ,bison)
("flex" ,flex)))
(inputs
`(("gmp" ,gmp)
("mpfr" ,mpfr)
("boost" ,boost)))
(arguments
`(#:configure-flags
(list (string-append "--libdir=" (assoc-ref %outputs "out")
"/lib/coq/user-contrib/Gappa"))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'fix-remake
(lambda _
(substitute* "remake.cpp"
(("/bin/sh") (which "sh")))
#t))
(replace 'build
(lambda _ (invoke "./remake")))
(replace 'check
(lambda _ (invoke "./remake" "check")))
(replace 'install
(lambda _ (invoke "./remake" "install"))))))
(home-page "http://gappa.gforge.inria.fr/")
(synopsis "Verify and formally prove properties on numerical programs")
(description "Gappa is a tool intended to help verifying and formally proving
properties on numerical programs dealing with floating-point or fixed-point
arithmetic. It has been used to write robust floating-point filters for CGAL
and it is used to certify elementary functions in CRlibm. While Gappa is
intended to be used directly, it can also act as a backend prover for the Why3
software verification plateform or as an automatic tactic for the Coq proof
assistant.")
(license (list license:gpl2+ license:cecill))));either gpl2+ or cecill
(define-public coq-mathcomp
(package
(name "coq-mathcomp")
(version "1.7.0")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/math-comp/math-comp/archive/mathcomp-"
version ".tar.gz"))
(sha256
(base32
"05zgyi4wmasi1rcyn5jq42w0bi9713q9m8dl1fdgl66nmacixh39"))))
(build-system gnu-build-system)
(native-inputs
`(("ocaml" ,ocaml)
("which" ,which)
("coq" ,coq)))
(arguments
`(#:tests? #f; No need to test formally-verified programs :)
#:phases
(modify-phases %standard-phases
(delete 'configure)
(add-before 'build 'chdir
(lambda _ (chdir "mathcomp") #t))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(setenv "COQLIB" (string-append (assoc-ref outputs "out") "/lib/coq/"))
(invoke "make" "-f" "Makefile.coq"
(string-append "COQLIB=" (assoc-ref outputs "out")
"/lib/coq/")
"install"))))))
(home-page "https://math-comp.github.io/math-comp/")
(synopsis "Mathematical Components for Coq")
(description "Mathematical Components for Coq has its origins in the formal
proof of the Four Colour Theorem. Since then it has grown to cover many areas
of mathematics and has been used for large scale projects like the formal proof
of the Odd Order Theorem.
The library is written using the Ssreflect proof language that is an integral
part of the distribution.")
(license license:cecill-b)))
(define-public coq-coquelicot
(package
(name "coq-coquelicot")
(version "3.0.1")
(source (origin
(method url-fetch)
(uri (string-append "https://gforge.inria.fr/frs/download.php/"
"file/37045/coquelicot-" version ".tar.gz"))
(sha256
(base32
"0hsyhsy2lwqxxx2r8xgi5csmirss42lp9bkb9yy35mnya0w78c8r"))))
(build-system gnu-build-system)
(native-inputs
`(("ocaml" ,ocaml)
("which" ,which)
("coq" ,coq)))
(propagated-inputs
`(("mathcomp" ,coq-mathcomp)))
(arguments
`(#:configure-flags
(list (string-append "--libdir=" (assoc-ref %outputs "out")
"/lib/coq/user-contrib/Coquelicot"))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'fix-coq8.8
(lambda _
; appcontext has been removed from coq 8.8
(substitute* "theories/AutoDerive.v"
(("appcontext") "context"))
#t))
(add-before 'configure 'fix-remake
(lambda _
(substitute* "remake.cpp"
(("/bin/sh") (which "sh")))
#t))
(replace 'build
(lambda _ (invoke "./remake")))
(replace 'check
(lambda _ (invoke "./remake" "check")))
(replace 'install
(lambda _ (invoke "./remake" "install"))))))
(home-page "http://coquelicot.saclay.inria.fr/index.html")
(synopsis "Coq library for Reals")
(description "Coquelicot is an easier way of writing formulas and theorem
statements, achieved by relying on total functions in place of dependent types
for limits, derivatives, integrals, power series, and so on. To help with the
proof process, the library comes with a comprehensive set of theorems that cover
not only these notions, but also some extensions such as parametric integrals,
two-dimensional differentiability, asymptotic behaviors. It also offers some
automations for performing differentiability proofs. Moreover, Coquelicot is a
conservative extension of Coq's standard library and provides correspondence
theorems between the two libraries.")
(license license:lgpl3+)))
(define-public coq-bignums
(package
(name "coq-bignums")
(version "8.8.0")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/coq/bignums/archive/V"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"08m1cmq4hkaf4sb0vy978c11rgzvds71cphyadmr2iirpr5815r0"))))
(build-system gnu-build-system)
(native-inputs
`(("ocaml" ,ocaml)
("coq" ,coq)))
(inputs
`(("camlp5" ,camlp5)))
(arguments
`(#:tests? #f; No test target
#:make-flags
(list (string-append "COQLIBINSTALL=" (assoc-ref %outputs "out")
"/lib/coq/user-contrib"))
#:phases
(modify-phases %standard-phases
(delete 'configure))))
(home-page "https://github.com/coq/bignums")
(synopsis "Coq library for arbitrary large numbers")
(description "Bignums is a coq library of arbitrary large numbers. It
provides BigN, BigZ, BigQ that used to be part of Coq standard library.")
(license license:lgpl2.1+)))
(define-public coq-interval
(package
(name "coq-interval")
(version "3.3.0")
(source (origin
(method url-fetch)
(uri (string-append "https://gforge.inria.fr/frs/download.php/"
"file/37077/interval-" version ".tar.gz"))
(sha256
(base32
"08fdcf3hbwqphglvwprvqzgkg0qbimpyhnqsgv3gac4y1ap0f903"))))
(build-system gnu-build-system)
(native-inputs
`(("ocaml" ,ocaml)
("which" ,which)
("coq" ,coq)))
(propagated-inputs
`(("flocq" ,coq-flocq)
("bignums" ,coq-bignums)
("coquelicot" ,coq-coquelicot)
("mathcomp" ,coq-mathcomp)))
(arguments
`(#:configure-flags
(list (string-append "--libdir=" (assoc-ref %outputs "out")
"/lib/coq/user-contrib/Gappa"))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'fix-remake
(lambda _
(substitute* "remake.cpp"
(("/bin/sh") (which "sh")))
#t))
(replace 'build
(lambda _ (invoke "./remake")))
(replace 'check
(lambda _ (invoke "./remake" "check")))
(replace 'install
(lambda _ (invoke "./remake" "install"))))))
(home-page "http://coq-interval.gforge.inria.fr/")
(synopsis "Coq tactics to simplify inequality proofs")
(description "Interval provides vernacular files containing tactics for
simplifying the proofs of inequalities on expressions of real numbers for the
Coq proof assistant.")
(license license:cecill-c)))

26
gnu/packages/cpp.scm
View File

@ -41,12 +41,15 @@
(version "0.4.37")
(source (origin
(method url-fetch)
;; Warning: This source has proved unreliable 1 time at least.
;; Consider an alternate source or report upstream if this
;; happens again.
(uri (string-append "https://mediaarea.net/download/source/"
name "/" version "/"
name "_" version ".tar.bz2"))
(sha256
(base32
"1hcsrmn85b0xp0mp33aazk7g071q1v3f163nnhv8b0mv9c4bgsfn"))))
"1dkqbgabzpa6bd7dkqrvd35sdxrhr6qxalb88f3dw0afk65xqb0k"))))
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
@ -58,10 +61,8 @@
(modify-phases %standard-phases
(add-after 'unpack 'pre-configure
(lambda _
(chdir "Project/GNU/Library")))
(add-after 'pre-configure 'autogen
(lambda _
(zero? (system* "sh" "autogen.sh")))))))
(chdir "Project/GNU/Library")
#t)))))
(home-page "https://github.com/MediaArea/ZenLib")
(synopsis "C++ utility library")
(description "ZenLib is a C++ utility library. It includes classes for handling
@ -202,15 +203,16 @@ as ordering relation.")
(package
(name "json-modern-cxx")
(version "3.1.2")
(home-page "https://github.com/nlohmann/json")
(source
(origin
(method url-fetch)
(uri (string-append
"https://github.com/nlohmann/json/archive/v" version ".tar.gz"))
(method git-fetch)
(uri (git-reference (url home-page)
(commit (string-append "v" version))))
(sha256
(base32
"0m5fhdpx2qll933db2nsi30nns3cifavzvijzz6mxhdkpmngmzz8"))
(file-name (string-append name "-" version ".tar.gz"))
"1mpr781fb2dfbyscrr7nil75lkxsazg4wkm749168lcf2ksrrbfi"))
(file-name (git-file-name name version))
(modules '((guix build utils)))
(snippet
'(begin
@ -226,13 +228,13 @@ as ordering relation.")
(substitute* files
(("#include ?\"(fifo_map.hpp)\"" all fifo-map-hpp)
(string-append
"#include <fifo_map/" fifo-map-hpp ">")))))))))
"#include <fifo_map/" fifo-map-hpp ">")))))
#t))))
(native-inputs
`(("amalgamate" ,amalgamate)))
(inputs
`(("catch2" ,catch-framework2)
("fifo-map" ,fifo-map)))
(home-page "https://github.com/nlohmann/json")
(build-system cmake-build-system)
(synopsis "JSON parser and printer library for C++")
(description "JSON for Modern C++ is a C++ JSON library that provides

2964
gnu/packages/cran.scm
View File

File diff suppressed because it is too large Load Diff

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