Merge branch 'master' into staging

master
Marius Bakke 2018-12-27 15:44:38 +01:00
commit af8fd11bed
No known key found for this signature in database
GPG Key ID: A2A06DF2A33A54FA
20 changed files with 484 additions and 166 deletions

View File

@ -2887,6 +2887,11 @@ Use @var{profile} instead of @file{~/.config/guix/current}.
Show which channel commit(s) would be used and what would be built or
substituted but do not actually do it.
@item --system=@var{system}
@itemx -s @var{system}
Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
the system type of the build host.
@item --verbose
Produce verbose output, writing build logs to the standard error output.
@ -7699,6 +7704,11 @@ URL. Check that the source file name is meaningful, e.g.@: is not just a
version number or ``git-checkout'', without a declared @code{file-name}
(@pxref{origin Reference}).
@item source-unstable-tarball
Parse the @code{source} URL to determine if a tarball from GitHub is
autogenerated or if it is a release tarball. Unfortunately GitHub's
autogenerated tarballs are sometimes regenerated.
@item cve
@cindex security vulnerabilities
@cindex CVE, Common Vulnerabilities and Exposures

View File

@ -41,6 +41,7 @@
;;; Copyright © 2018 Alex Branham <alex.branham@gmail.com>
;;; Copyright © 2018 Thorsten Wilms <t_w_@freenet.de>
;;; Copyright © 2018 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2018 Gabriel Hondet <gabrielhondet@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -122,6 +123,7 @@
#:use-module (gnu packages video)
#:use-module (gnu packages haskell)
#:use-module (gnu packages wordnet)
#:use-module (gnu packages ocaml)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match))
@ -12862,3 +12864,59 @@ functions to ensure they are called with the right arguments during testing.")
@code{wordnet}. Features include completion, if the query is not found
too ambiguous and navigation in the result buffer.")
(license license:gpl3+))))
(define-public emacs-dedukti-mode
(let ((commit "d7c3505a1046187de3c3aeb144455078d514594e"))
(package
(name "emacs-dedukti-mode")
(version (git-version "0" "0" commit))
(home-page "https://github.com/rafoo/dedukti-mode")
(source (origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(sha256
(base32
"1842wikq24c8rg0ac84vb1qby9ng1nssxswyyni4kq85lng5lcrp"))
(file-name (git-file-name name version))))
(inputs
`(("dedukti" ,dedukti)))
(build-system emacs-build-system)
(arguments
'(#:phases
(modify-phases %standard-phases
(add-before 'install 'patch-dkpath
(lambda _
(let ((dkcheck-path (which "dkcheck")))
(substitute* "dedukti-mode.el"
(("dedukti-path \"(.*)\"")
(string-append "dedukti-path \"" dkcheck-path "\"")))))))))
(synopsis "Emacs major mode for Dedukti files")
(description "This package provides an Emacs major mode for editing
Dedukti files.")
(license license:cecill-b))))
(define-public emacs-flycheck-dedukti
(let ((commit "3dbff5646355f39d57a3ec514f560a6b0082a1cd"))
(package
(name "emacs-flycheck-dedukti")
(version (git-version "0" "0" commit))
(home-page "https://github.com/rafoo/flycheck-dedukti")
(source (origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(sha256
(base32
"1ffpxnwl3wx244n44mbw81g00nhnykd0lnid29f4aw1av7w6nw8l"))
(file-name (git-file-name name version))))
(build-system emacs-build-system)
(inputs
`(("dedukti-mode" ,emacs-dedukti-mode)
("flycheck-mode" ,emacs-flycheck)))
(synopsis "Flycheck integration for the dedukti language")
(description "This package provides a frontend for Flycheck to perform
syntax checking on dedukti files.")
(license license:cecill-b))))

View File

@ -184,7 +184,7 @@ removable devices or support for multimedia.")
(define-public terminology
(package
(name "terminology")
(version "1.3.0")
(version "1.3.2")
(source (origin
(method url-fetch)
(uri
@ -192,7 +192,7 @@ removable devices or support for multimedia.")
"terminology/terminology-" version ".tar.xz"))
(sha256
(base32
"07vw28inkimi9avp16j0rqcfqjq16081554qsv29pcqhz18xp59r"))
"1kclxzadmk272s9spa7n704pcb1c611ixxrq88w5zk22va0i25xm"))
(modules '((guix build utils)))
;; Remove the bundled fonts.
(snippet

View File

@ -2329,4 +2329,33 @@ Scheme by using Guiles foreign function interface.")
(home-page "https://gitlab.com/mothacehe/guile-newt")
(license license:gpl3+))))
(define-public guile-mastodon
(package
(name "guile-mastodon")
(version "0.0.1")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://framagit.org/prouby/guile-mastodon.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1vblf3d1bbwna3l09p2ap5y8ycvl549bz6whgk78imyfmn28ygry"))))
(build-system gnu-build-system)
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
("pkg-config" ,pkg-config)))
(inputs
`(("guile" ,guile-2.2)
("gnutls" ,gnutls)
("guile-json" ,guile-json)))
(home-page "https://framagit.org/prouby/guile-mastodon")
(synopsis "Guile Mastodon REST API module")
(description "This package provides Guile modules to access the
@uref{https://docs.joinmastodon.org/api/, REST API of Mastodon}, a federated
microblogging service.")
(license license:gpl3+)))
;;; guile.scm ends here

View File

@ -238,12 +238,14 @@ it and customize it for your needs.")
(version "1.7")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/hellosiyan/Viewnior/archive/"
name "-" version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://github.com/hellosiyan/Viewnior.git")
(commit (string-append name "-" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1rpkk721s3xas125q3g0fl11b5zsrmzv9pzl6ddzcy4sj2rd7ymr"))))
"0y4hk3vq8psba5k615w18qj0kbdfp5w0lm98nv5apy6hmcpwfyig"))))
(build-system meson-build-system)
(arguments
'(#:phases

View File

@ -6140,6 +6140,11 @@ printed.")
(modify-phases %standard-phases
(add-after 'install 'strip-jar-timestamps
(assoc-ref ant:%standard-phases 'strip-jar-timestamps))
(add-before 'configure 'fix-timestamp
(lambda _
(substitute* "configure"
(("^TIMESTAMP.*") "TIMESTAMP=19700101\n"))
#t))
(add-after 'configure 'fix-bin-ls
(lambda _
(substitute* (find-files "." "Makefile")

View File

@ -268,7 +268,7 @@ alternatives. In compilers, this can reduce the cascade of secondary errors.")
(define-public kodi
(package
(name "kodi")
(version "18.0rc1")
(version "18.0rc3")
(source (origin
(method git-fetch)
(uri (git-reference
@ -277,7 +277,7 @@ alternatives. In compilers, this can reduce the cascade of secondary errors.")
(file-name (git-file-name name version))
(sha256
(base32
"0xzzp4x8l0ywx8aq93a1323il6wwslmgdbhasv0r8zp3w1c0wqf1"))
"0bwi4gwmwppjw6bf0zihyg42zwnd0imq0aw4xxsgnacqakhxzii0"))
(snippet
'(begin
(use-modules (guix build utils))

View File

@ -937,7 +937,7 @@ Zerofree requires the file system to be unmounted or mounted read-only.")
(define-public strace
(package
(name "strace")
(version "4.25")
(version "4.26")
(home-page "https://strace.io")
(source (origin
(method url-fetch)
@ -945,7 +945,7 @@ Zerofree requires the file system to be unmounted or mounted read-only.")
"/strace-" version ".tar.xz"))
(sha256
(base32
"00f7zagfh3np5gwi0z7hi7zjd7s5nixcaq7z78n87dvhakkgi1fn"))))
"070yz8xii8gnb4psiz628zwm5srh266sfb06f7f1qzagxzz2ykbw"))))
(build-system gnu-build-system)
(arguments
'(#:phases
@ -964,7 +964,7 @@ Zerofree requires the file system to be unmounted or mounted read-only.")
(description
"strace is a system call tracer, i.e. a debugging tool which prints out a
trace of all the system calls made by a another process/program.")
(license license:bsd-3)))
(license license:lgpl2.1+)))
(define-public ltrace
(package

View File

@ -298,46 +298,46 @@ functional, imperative and object-oriented styles of programming.")
(define-public ocaml ocaml-4.07)
(define-public ocamlbuild
(package
(name "ocamlbuild")
(version "0.13.1")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/ocaml/ocamlbuild/archive/"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"1320cfkixs1xlng5av04pa5qjb3ynvi2kl3k1ngqzg5fpi29b0vr"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
#:tests? #f; tests require findlib
#:make-flags
(list (string-append "OCAMLBUILD_PREFIX=" (assoc-ref %outputs "out"))
(string-append "OCAMLBUILD_BINDIR=" (assoc-ref %outputs "out")
"/bin")
(string-append "OCAMLBUILD_LIBDIR=" (assoc-ref %outputs "out")
"/lib/ocaml/site-lib")
(string-append "OCAMLBUILD_MANDIR=" (assoc-ref %outputs "out")
"/share/man"))
#:phases
(modify-phases %standard-phases
(delete 'bootstrap)
(delete 'configure)
(add-before 'build 'findlib-environment
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out")))
(setenv "OCAMLFIND_DESTDIR" (string-append out "/lib/ocaml/site-lib"))
(setenv "OCAMLFIND_LDCONF" "ignore")
#t))))))
(native-inputs
`(("ocaml" ,ocaml)))
(home-page "https://github.com/ocaml/ocamlbuild")
(synopsis "OCaml build tool")
(description "OCamlbuild is a generic build tool, that has built-in rules
for building OCaml library and programs.")
(license license:lgpl2.1+)))
(package
(name "ocamlbuild")
(version "0.13.1")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/ocaml/ocamlbuild/archive/"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"1320cfkixs1xlng5av04pa5qjb3ynvi2kl3k1ngqzg5fpi29b0vr"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
#:tests? #f; tests require findlib
#:make-flags
(list (string-append "OCAMLBUILD_PREFIX=" (assoc-ref %outputs "out"))
(string-append "OCAMLBUILD_BINDIR=" (assoc-ref %outputs "out")
"/bin")
(string-append "OCAMLBUILD_LIBDIR=" (assoc-ref %outputs "out")
"/lib/ocaml/site-lib")
(string-append "OCAMLBUILD_MANDIR=" (assoc-ref %outputs "out")
"/share/man"))
#:phases
(modify-phases %standard-phases
(delete 'bootstrap)
(delete 'configure)
(add-before 'build 'findlib-environment
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out")))
(setenv "OCAMLFIND_DESTDIR" (string-append out "/lib/ocaml/site-lib"))
(setenv "OCAMLFIND_LDCONF" "ignore")
#t))))))
(native-inputs
`(("ocaml" ,ocaml)))
(home-page "https://github.com/ocaml/ocamlbuild")
(synopsis "OCaml build tool")
(description "OCamlbuild is a generic build tool, that has built-in rules
for building OCaml library and programs.")
(license license:lgpl2.1+)))
(define-public opam
(package
@ -5018,11 +5018,11 @@ Coq proof assistant.")
(replace 'build
(lambda _
(invoke "make")
#t))
#t))
(replace 'check
(lambda _
(invoke "make" "tests")
#t))
#t))
(add-before 'install 'set-binpath
;; Change binary path in the makefile
(lambda _
@ -5030,11 +5030,11 @@ Coq proof assistant.")
(substitute* "GNUmakefile"
(("BINDIR = (.*)$")
(string-append "BINDIR = " out "/bin"))))
#t))
(replace 'install
(lambda _
(invoke "make" "install")
#t)))))
#t))
(replace 'install
(lambda _
(invoke "make" "install")
#t)))))
(synopsis "Proof-checker for the λΠ-calculus modulo theory, an extension of
the λ-calculus")
(description "Dedukti is a proof-checker for the λΠ-calculus modulo
@ -5044,3 +5044,64 @@ dependent types. The λΠ-calculus modulo theory is itself an extension of the
rules. This system is not designed to develop proofs, but to check proofs
developed in other systems. In particular, it enjoys a minimalistic syntax.")
(license license:cecill-c)))
(define-public ocaml-biniou
(package
(name "ocaml-biniou")
(version "1.2.0")
(home-page "https://github.com/mjambon/biniou")
(source
(origin
(method git-fetch)
(uri (git-reference
(url (string-append home-page ".git"))
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0mjpgwyfq2b2izjw0flmlpvdjgqpq8shs89hxj1np2r50csr8dcb"))))
(build-system dune-build-system)
(inputs
`(("ocaml-easy-format" ,ocaml-easy-format)))
(native-inputs
`(("which" ,which)))
(synopsis "Data format designed for speed, safety, ease of use and backward
compatibility")
(description "Biniou (pronounced \"be new\" is a binary data format
designed for speed, safety, ease of use and backward compatibility as
protocols evolve. Biniou is vastly equivalent to JSON in terms of
functionality but allows implementations several times faster (4 times faster
than yojson), with 25-35% space savings.")
(license license:bsd-3)))
(define-public ocaml-yojson
(package
(name "ocaml-yojson")
(version "1.4.1")
(home-page "https://github.com/ocaml-community/yojson")
(source
(origin
(method git-fetch)
(uri (git-reference
(url (string-append home-page ".git"))
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0nwsfkmqpyfab4rxq76q8ff7giyanghw08094jyrp275v99zdjr9"))))
(build-system dune-build-system)
(arguments
`(#:test-target "."))
(inputs
`(("ocaml-biniou" ,ocaml-biniou)
("ocaml-easy-format" ,ocaml-easy-format)))
(native-inputs
`(("ocaml-cppo" ,ocaml-cppo)))
(synopsis "Low-level JSON library for OCaml")
(description "Yojson is an optimized parsing and printing library for the
JSON format. It addresses a few shortcomings of json-wheel including 2x
speedup, polymorphic variants and optional syntax for tuples and variants.
@code{ydump} is a pretty printing command-line program provided with the
yojson package. The program @code{atdgen} can be used to derive OCaml-JSON
serializers and deserializers from type definitions.")
(license license:bsd-3)))

View File

@ -105,8 +105,8 @@
;; Note: the 'update-guix-package.scm' script expects this definition to
;; start precisely like this.
(let ((version "0.16.0")
(commit "6f1e0bb79266f34b50b09200b9280a641b8aa7c8")
(revision 7))
(commit "7ba2b27467a39956f10e2e11061d9569e4b7d632")
(revision 8))
(package
(name "guix")
@ -122,7 +122,7 @@
(commit commit)))
(sha256
(base32
"0xk4ki5zsliwknxc9a3lvpjzpckz8nx4dz55xmw9sydq5z5mmy50"))
"14srgkl0vyr6q7azv76nncp63gngmm71y18ybyj9f6l6s4shbcm4"))
(file-name (string-append "guix-" version "-checkout"))))
(build-system gnu-build-system)
(arguments

View File

@ -150,14 +150,14 @@ anywhere.")
(define-public samba
(package
(name "samba")
(version "4.9.3")
(version "4.9.4")
(source (origin
(method url-fetch)
(uri (string-append "https://download.samba.org/pub/samba/stable/"
"samba-" version ".tar.gz"))
(sha256
(base32
"1krm47x08c0vcrq12dxs8mbicma1ck2sl1i0hgkvrmwsgrqdi3yg"))))
"0kqbzywlnh1skg6g78qilyn12qv7wri66h5v9f77igncpkcai63d"))))
(build-system gnu-build-system)
(arguments
`(#:phases

View File

@ -37,6 +37,7 @@
#:use-module (guix utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system trivial)
#:use-module (gnu packages autotools)
#:use-module (gnu packages bdw-gc)
#:use-module (gnu packages compression)
#:use-module (gnu packages libevent)
@ -85,8 +86,7 @@
(outputs '("out" "doc"))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; no "check" target
#:modules ((guix build gnu-build-system)
`(#:modules ((guix build gnu-build-system)
(guix build utils)
(srfi srfi-1))
#:phases
@ -103,6 +103,20 @@
(find-files "src/compiler" "^make\\."))
(chdir "src")
#t))
(add-after 'unpack 'patch-/bin/sh
(lambda _
(setenv "CONFIG_SHELL" (which "sh"))
(substitute* '("../tests/ffi/autogen.sh"
"../tests/ffi/autobuild.sh"
"../tests/ffi/test-ffi.sh"
"../tests/runtime/test-process.scm"
"runtime/unxprm.scm")
(("/bin/sh") (which "sh"))
(("\\./autogen\\.sh")
(string-append (which "sh") " autogen.sh"))
(("\\./configure")
(string-append (which "sh") " configure")))
#t))
;; FIXME: the texlive-union insists on regenerating fonts. It stores
;; them in HOME, so it needs to be writeable.
(add-before 'build 'set-HOME
@ -150,7 +164,11 @@
(delete-file-recursively old-doc-dir)
#t))))))
(native-inputs
`(("texlive" ,(texlive-union (list texlive-tex-texinfo)))
`(;; Autoconf, Automake, and Libtool are necessary for the FFI tests.
("autoconf" ,autoconf)
("automake" ,automake)
("libtool" ,libtool)
("texlive" ,(texlive-union (list texlive-tex-texinfo)))
("texinfo" ,texinfo)
("m4" ,m4)))
(inputs

View File

@ -833,7 +833,7 @@ then ported to the GNU / Linux environment.")
(define-public mbedtls-apache
(package
(name "mbedtls-apache")
(version "2.14.1")
(version "2.16.0")
(source
(origin
(method url-fetch)
@ -843,7 +843,7 @@ then ported to the GNU / Linux environment.")
version "-apache.tgz"))
(sha256
(base32
"07f6xn77w5rd6fhq5s1dmna3czs4chk5j2s6wkj366cvikawp2gi"))))
"1qlscr0m97favkqmrlj90rlgw40h8lcypxz0snvr1iwkj1pbbnp3"))))
(build-system cmake-build-system)
(arguments
`(#:configure-flags

View File

@ -63,13 +63,14 @@
(name "vim")
(version "8.1.0551")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/vim/vim/archive/v"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(method git-fetch)
(uri (git-reference
(url "https://github.com/vim/vim")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1wi6j9w04wg3hxsch3izl2mxb0065vpvxscz19zjn5ypkfypnm8n"))))
"1db5ihzj9flz62alb3kd1w173chb5vbni325abqjf25aly7c22n0"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
@ -103,7 +104,7 @@
("ncurses" ,ncurses)
("perl" ,perl)
("tcsh" ,tcsh))) ; For runtime/tools/vim32
(home-page "http://www.vim.org/")
(home-page "https://www.vim.org/")
(synopsis "Text editor based on vi")
(description
"Vim is a highly configurable text editor built to enable efficient text

View File

@ -7,6 +7,7 @@
;;; Copyright © 2016, 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2018 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2018 Meiyo Peng <meiyo.peng@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -28,6 +29,7 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (guix build-system python)
#:use-module (gnu packages)
@ -37,6 +39,7 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages gnuzilla)
#:use-module (gnu packages libevent)
#:use-module (gnu packages linux)
#:use-module (gnu packages perl)
@ -400,3 +403,47 @@ DNS domain name queries.")
@command{sshuttle} virtual private networks. It supports flexible profiles
with configuration options for most of @command{sshuttle}s features.")
(license license:gpl3+)))
(define-public badvpn
(package
(name "badvpn")
(version "1.999.130")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/ambrop72/badvpn.git")
(commit version)))
(file-name (git-file-name name version))
(sha256
(base32 "0rm67xhi7bh3yph1vh07imv5y1pwyldvw3wa5bz471g8mnkc7d3c"))))
(build-system cmake-build-system)
(arguments
'(#:tests? #f)) ; no tests
(inputs
`(("nspr" ,nspr)
("nss" ,nss)
("openssl" ,openssl)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "https://github.com/ambrop72/badvpn")
(synopsis "Peer-to-peer virtual private network (VPN)")
(description "@code{BadVPN} is a collection of virtual private
network (VPN) tools. It includes:
@enumerate
@item NCD programming language.\n
NCD (Network Configuration Daemon) is a daemon and programming/scripting
language for configuration of network interfaces and other aspects of the
operating system.
@item Tun2socks network-layer proxifier.\n
The tun2socks program socksifes TCP connections at the network layer. It
implements a TUN device which accepts all incoming TCP connections (regardless
of destination IP), and forwards the connections through a SOCKS server.
@item Peer-to-peer VPN.\n
The peer-to-peer VPN implements a Layer 2 (Ethernet) network between the peers
(VPN nodes).
@end enumerate")
;; This project contains a bundled lwIP. lwIP is also released under the
;; 3-clause BSD license.
(license license:bsd-3)))

View File

@ -913,7 +913,7 @@ listed in OS. The C library expects to find it under
" (beta)"))
((inferior-package? kernel)
(string-append "GNU with "
(string-titlecase (inferior-package-name kernel))
(string-titlecase (inferior-package-name kernel)) " "
(inferior-package-version kernel)
" (beta)"))
(else "GNU")))

View File

@ -7,7 +7,7 @@
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
@ -76,6 +76,7 @@
check-home-page
check-source
check-source-file-name
check-source-unstable-tarball
check-mirror-url
check-github-url
check-license
@ -752,6 +753,22 @@ descriptions maintained upstream."
(G_ "the source file name should contain the package name")
'source))))
(define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball."
(define (check-source-uri uri)
(when (and (string=? (uri-host (string->uri uri)) "github.com")
(string=? (third (split-and-decode-uri-path
(uri-path (string->uri uri))))
"archive"))
(emit-warning package
(G_ "the source URI should not be an autogenerated tarball")
'source)))
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
(let ((uris (origin-uris origin)))
(for-each check-source-uri uris)))))
(define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'."
(define (check-mirror-uri uri) ;XXX: could be optimized
@ -1098,6 +1115,10 @@ or a list thereof")
(name 'source-file-name)
(description "Validate file names of sources")
(check check-source-file-name))
(lint-checker
(name 'source-unstable-tarball)
(description "Check for autogenerated tarballs")
(check check-source-unstable-tarball))
(lint-checker
(name 'derivation)
(description "Report failure to compile a package to a derivation")

View File

@ -260,13 +260,6 @@ instead of '~a' of type '~a'~%")
(lambda ()
(unlock-file port)))))
(define-syntax-rule (with-machine-lock machine hint exp ...)
"Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that
context."
(with-file-lock (machine-lock-file machine hint)
exp ...))
(define (machine-slot-file machine slot)
"Return the file name of MACHINE's file for SLOT."
;; For each machine we have a bunch of files representing each build slot.
@ -284,23 +277,25 @@ the slot, or #f if none is available.
This mechanism allows us to set a hard limit on the number of simultaneous
connections allowed to MACHINE."
(mkdir-p (dirname (machine-slot-file machine 0)))
(with-machine-lock machine 'slots
(any (lambda (slot)
(let ((port (open-file (machine-slot-file machine slot)
"w0")))
(catch 'flock-error
(lambda ()
(fcntl-flock port 'write-lock #:wait? #f)
;; Got it!
(format (current-error-port)
"process ~a acquired build slot '~a'~%"
(getpid) (port-filename port))
port)
(lambda args
;; PORT is already locked by another process.
(close-port port)
#f))))
(iota (build-machine-parallel-builds machine)))))
;; When several 'guix offload' processes run in parallel, there's a race
;; among them, but since they try the slots in the same order, we're fine.
(any (lambda (slot)
(let ((port (open-file (machine-slot-file machine slot)
"w0")))
(catch 'flock-error
(lambda ()
(fcntl-flock port 'write-lock #:wait? #f)
;; Got it!
(format (current-error-port)
"process ~a acquired build slot '~a'~%"
(getpid) (port-filename port))
port)
(lambda args
;; PORT is already locked by another process.
(close-port port)
#f))))
(iota (build-machine-parallel-builds machine))))
(define (release-build-slot slot)
"Release SLOT, a build slot as returned as by 'acquire-build-slot'."
@ -447,16 +442,6 @@ of free disk space on '~a'~%")
normalized)
load))
(define (machine-lock-file machine hint)
"Return the name of MACHINE's lock file for HINT."
(string-append %state-directory "/offload/"
(build-machine-name machine)
"." (symbol->string hint) ".lock"))
(define (machine-choice-lock-file)
"Return the name of the file used as a lock when choosing a build machine."
(string-append %state-directory "/offload/machine-choice.lock"))
(define (random-seed)
(logxor (getpid) (car (gettimeofday))))
@ -479,67 +464,64 @@ of free disk space on '~a'~%")
slot (which must later be released with 'release-build-slot'), or #f and #f."
;; Proceed like this:
;; 1. Acquire the global machine-choice lock.
;; 2. For all MACHINES, attempt to acquire a build slot, and filter out
;; 1. For all MACHINES, attempt to acquire a build slot, and filter out
;; those machines for which we failed.
;; 3. Choose the best machine among those that are left.
;; 4. Release the previously-acquired build slots of the other machines.
;; 5. Release the global machine-choice lock.
;; 2. Choose the best machine among those that are left.
;; 3. Release the previously-acquired build slots of the other machines.
(with-file-lock (machine-choice-lock-file)
(define machines+slots
(filter-map (lambda (machine)
(let ((slot (acquire-build-slot machine)))
(and slot (list machine slot))))
(shuffle machines)))
(define machines+slots
(filter-map (lambda (machine)
(let ((slot (acquire-build-slot machine)))
(and slot (list machine slot))))
(shuffle machines)))
(define (undecorate pred)
(lambda (a b)
(match a
((machine1 slot1)
(match b
((machine2 slot2)
(pred machine1 machine2)))))))
(define (undecorate pred)
(lambda (a b)
(match a
((machine1 slot1)
(match b
((machine2 slot2)
(pred machine1 machine2)))))))
(define (machine-faster? m1 m2)
;; Return #t if M1 is faster than M2.
(> (build-machine-speed m1)
(build-machine-speed m2)))
(define (machine-faster? m1 m2)
;; Return #t if M1 is faster than M2.
(> (build-machine-speed m1)
(build-machine-speed m2)))
(let loop ((machines+slots
(sort machines+slots (undecorate machine-faster?))))
(match machines+slots
(((best slot) others ...)
;; Return the best machine unless it's already overloaded.
;; Note: We call 'node-load' only as a last resort because it is
;; too costly to call it once for every machine.
(let* ((session (false-if-exception (open-ssh-session best)))
(node (and session (remote-inferior session)))
(load (and node (normalized-load best (node-load node))))
(space (and node (node-free-disk-space node))))
(when node (close-inferior node))
(when session (disconnect! session))
(if (and node (< load 2.) (>= space %minimum-disk-space))
(match others
(((machines slots) ...)
;; Release slots from the uninteresting machines.
(for-each release-build-slot slots)
(let loop ((machines+slots
(sort machines+slots (undecorate machine-faster?))))
(match machines+slots
(((best slot) others ...)
;; Return the best machine unless it's already overloaded.
;; Note: We call 'node-load' only as a last resort because it is
;; too costly to call it once for every machine.
(let* ((session (false-if-exception (open-ssh-session best)))
(node (and session (remote-inferior session)))
(load (and node (normalized-load best (node-load node))))
(space (and node (node-free-disk-space node))))
(when node (close-inferior node))
(when session (disconnect! session))
(if (and node (< load 2.) (>= space %minimum-disk-space))
(match others
(((machines slots) ...)
;; Release slots from the uninteresting machines.
(for-each release-build-slot slots)
;; The caller must keep SLOT to protect it from GC and to
;; eventually release it.
(values best slot)))
(begin
;; BEST is unsuitable, so try the next one.
(when (and space (< space %minimum-disk-space))
(format (current-error-port)
"skipping machine '~a' because it is low \
;; The caller must keep SLOT to protect it from GC and to
;; eventually release it.
(values best slot)))
(begin
;; BEST is unsuitable, so try the next one.
(when (and space (< space %minimum-disk-space))
(format (current-error-port)
"skipping machine '~a' because it is low \
on disk space (~,2f MiB free)~%"
(build-machine-name best)
(/ space (expt 2 20) 1.)))
(release-build-slot slot)
(loop others)))))
(()
(values #f #f))))))
(build-machine-name best)
(/ space (expt 2 20) 1.)))
(release-build-slot slot)
(loop others)))))
(()
(values #f #f)))))
(define (call-with-timeout timeout drv thunk)
"Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call
@ -834,7 +816,6 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
(leave (G_ "invalid arguments: ~{~s ~}~%") x))))
;;; Local Variables:
;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
;;; eval: (put 'with-timeout 'scheme-indent-function 2)

View File

@ -126,6 +126,10 @@ Download and deploy the latest version of Guix.\n"))
(lambda (opt name arg result)
(alist-cons 'profile (canonicalize-profile arg)
result)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
(alist-delete 'system result eq?))))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
@ -505,7 +509,8 @@ Use '~/.config/guix/channels.scm' instead."))
(else
(with-store store
(with-status-report print-build-event
(parameterize ((%graft? (assoc-ref opts 'graft?))
(parameterize ((%current-system (assoc-ref opts 'system))
(%graft? (assoc-ref opts 'graft?))
(%repository-cache-directory cache))
(set-build-options-from-command-line store opts)
(honor-x509-certificates store)

View File

@ -572,6 +572,86 @@
(check-source-file-name pkg)))
"file name should contain the package name"))))
(test-assert "source-unstable-tarball"
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://github.com/example/example/archive/v0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
"source URI should not be an autogenerated tarball"))
(test-assert "source-unstable-tarball: source #f"
(not
(->bool
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source #f))))
(check-source-unstable-tarball pkg)))
"source URI should not be an autogenerated tarball"))))
(test-assert "source-unstable-tarball: valid"
(not
(->bool
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
"source URI should not be an autogenerated tarball"))))
(test-assert "source-unstable-tarball: package named archive"
(not
(->bool
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
"source URI should not be an autogenerated tarball"))))
(test-assert "source-unstable-tarball: not-github"
(not
(->bool
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
"source URI should not be an autogenerated tarball"))))
(test-assert "source-unstable-tarball: git-fetch"
(not
(->bool
(string-contains
(with-warnings
(let ((pkg (dummy-package "x"
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/archive/example.git")
(commit "0")))
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
"source URI should not be an autogenerated tarball"))))
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
""