summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cargo.scm11
-rw-r--r--guix/build-system/julia.scm130
-rw-r--r--guix/build/cargo-build-system.scm14
-rw-r--r--guix/build/julia-build-system.scm135
-rw-r--r--guix/build/lisp-utils.scm14
-rw-r--r--guix/bzr-download.scm3
-rw-r--r--guix/ci.scm68
-rw-r--r--guix/cvs-download.scm5
-rw-r--r--guix/git-download.scm3
-rw-r--r--guix/hg-download.scm5
-rw-r--r--guix/import/cran.scm37
-rw-r--r--guix/import/crate.scm164
-rw-r--r--guix/import/opam.scm6
-rw-r--r--guix/json.scm62
-rw-r--r--guix/lint.scm166
-rw-r--r--guix/scripts/deploy.scm12
-rw-r--r--guix/scripts/system.scm6
-rw-r--r--guix/svn-download.scm5
-rw-r--r--guix/swh.scm123
-rw-r--r--guix/tests/http.scm39
20 files changed, 783 insertions, 225 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index 10a1bac844..1e8b3a578e 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
@@ -35,12 +35,17 @@
#:export (%cargo-build-system-modules
%cargo-utils-modules
cargo-build-system
+ %crate-base-url
crate-url
crate-url?
crate-uri))
-(define crate-url "https://crates.io/api/v1/crates/")
-(define crate-url? (cut string-prefix? crate-url <>))
+(define %crate-base-url
+ (make-parameter "https://crates.io"))
+(define crate-url
+ (string-append (%crate-base-url) "/api/v1/crates/"))
+(define crate-url?
+ (cut string-prefix? crate-url <>))
(define (crate-uri name version)
"Return a URI string for the crate package hosted at crates.io corresponding
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm
new file mode 100644
index 0000000000..488fe9bb1d
--- /dev/null
+++ b/guix/build-system/julia.scm
@@ -0,0 +1,130 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
+;;;
+;;; 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 (guix build-system julia)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (%julia-build-system-modules
+ julia-build
+ julia-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for Julia packages.
+;;
+;; Code:
+
+(define %julia-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build julia-build-system)
+ ,@%gnu-build-system-modules))
+
+(define (default-julia)
+ "Return the default Julia package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((julia-mod (resolve-interface '(gnu packages julia))))
+ (module-ref julia-mod 'julia)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (julia (default-julia))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:target #:julia #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("julia" ,julia)
+ ,@native-inputs))
+ (outputs outputs)
+ (build julia-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (julia-build store name inputs
+ #:key source
+ (tests? #f)
+ (phases '(@ (guix build julia-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %julia-build-system-modules)
+ (modules '((guix build julia-build-system)
+ (guix build utils))))
+ "Build SOURCE using Julia, and with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (julia-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define julia-build-system
+ (build-system
+ (name 'julia)
+ (description "The build system for Julia packages")
+ (lower lower)))
+
+;;; julia.scm ends here
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 06ed14b89f..f173b64c83 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -81,10 +81,10 @@ Cargo.toml file present at its root."
;; archive, but not nested anywhere else). We do this by cutting up
;; each output line and only looking at the second component. We then
;; check if it matches Cargo.toml exactly and short circuit if it does.
- (zero? (apply system* (list "sh" "-c"
- (string-append "tar -tf " path
- " | cut -d/ -f2"
- " | grep -q '^Cargo.toml$'"))))))
+ (apply invoke (list "sh" "-c"
+ (string-append "tar -tf " path
+ " | cut -d/ -f2"
+ " | grep -q '^Cargo.toml$'")))))
(define* (configure #:key inputs
(vendor-dir "guix-vendor")
@@ -157,7 +157,7 @@ directory = '" port)
#:allow-other-keys)
"Build a given Cargo package."
(or skip-build?
- (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))))
+ (apply invoke `("cargo" "build" ,@cargo-build-flags))))
(define* (check #:key
tests?
@@ -165,7 +165,7 @@ directory = '" port)
#:allow-other-keys)
"Run tests for a given Cargo package."
(if tests?
- (zero? (apply system* `("cargo" "test" ,@cargo-test-flags)))
+ (apply invoke `("cargo" "test" ,@cargo-test-flags))
#t))
(define (touch file-name)
@@ -184,7 +184,7 @@ directory = '" port)
;; otherwise cargo will raise an error.
(or skip-build?
(not (has-executable-target?))
- (zero? (system* "cargo" "install" "--path" "." "--root" out)))))
+ (invoke "cargo" "install" "--path" "." "--root" out))))
(define %standard-phases
(modify-phases gnu:%standard-phases
diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm
new file mode 100644
index 0000000000..ff6fcf5fe3
--- /dev/null
+++ b/guix/build/julia-build-system.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
+;;;
+;;; 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 (guix build julia-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 match)
+ #:export (%standard-phases
+ julia-create-package-toml
+ julia-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard build procedure for Julia packages.
+;;
+;; Code:
+
+(define (invoke-julia code)
+ (invoke "julia" "-e" code))
+
+;; subpath where we store the package content
+(define %package-path "/share/julia/packages/")
+
+(define (generate-load-path inputs outputs)
+ (string-append
+ (string-join (map (match-lambda
+ ((_ . path)
+ (string-append path %package-path)))
+ ;; Restrict to inputs beginning with "julia-".
+ (filter (match-lambda
+ ((name . _)
+ (string-prefix? "julia-" name)))
+ inputs))
+ ":")
+ (string-append ":" (assoc-ref outputs "out") %package-path)
+ ;; stdlib is always required to find Julia's standard libraries.
+ ;; usually there are other two paths in this variable:
+ ;; "@" and "@v#.#"
+ ":@stdlib"))
+
+(define* (install #:key source inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (package-dir (string-append out %package-path
+ (string-append
+ (strip-store-file-name source)))))
+ (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+ (mkdir-p package-dir)
+ (copy-recursively source package-dir))
+ #t)
+
+;; TODO: Precompilation is working, but I don't know how to tell
+;; julia to use use it. If (on rantime) we set HOME to
+;; store path, julia tries to write files there (failing)
+(define* (precompile #:key source inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (builddir (string-append out "/share/julia/"))
+ (package (strip-store-file-name source)))
+ (mkdir-p builddir)
+ (setenv "JULIA_DEPOT_PATH" builddir)
+ (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+ ;; Actual precompilation
+ (invoke-julia (string-append "using " package)))
+ #t)
+
+(define* (check #:key source inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (package (strip-store-file-name source))
+ (builddir (string-append out "/share/julia/")))
+ (setenv "JULIA_DEPOT_PATH" builddir)
+ (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+ (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")")))
+ #t)
+
+(define (julia-create-package-toml outputs source
+ name uuid version
+ deps)
+ "Some packages are not using the new Package.toml dependency specifications.
+Write this file manually, so that Julia can find its dependencies."
+ (let ((f (open-file
+ (string-append
+ (assoc-ref outputs "out")
+ %package-path
+ (string-append
+ name "/Project.toml"))
+ "w")))
+ (display (string-append
+ "
+name = \"" name "\"
+uuid = \"" uuid "\"
+version = \"" version "\"
+") f)
+ (when (not (null? deps))
+ (display "[deps]\n" f)
+ (for-each (lambda dep
+ (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n")
+ f))
+ deps))
+ (close-port f))
+ #t)
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'check) ; tests must be run after installation
+ (replace 'install install)
+ (add-after 'install 'precompile precompile)
+ ;; (add-after 'install 'check check)
+ ;; TODO: In the future we could add a "system-image-generation" phase
+ ;; where we use PackageCompiler.jl to speed up package loading times
+ (delete 'configure)
+ (delete 'bootstrap)
+ (delete 'patch-usr-bin-file)
+ (delete 'build)))
+
+(define* (julia-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given Julia package, applying all of PHASES in order."
+ (apply gnu:gnu-build
+ #:inputs inputs #:phases phases
+ args))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 97bc6197a3..c7a589c902 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -220,12 +220,19 @@ Also load TEST-ASD-FILE if necessary."
"Return a lisp keyword for the concatenation of STRINGS."
(string->symbol (apply string-append ":" strings)))
-(define (generate-executable-for-system type system)
+(define* (generate-executable-for-system type system #:key compress?)
"Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
'asdf:program-op. The latter will always be standalone. Depends on having
created a \"SYSTEM-exec\" system which contains the entry program."
(lisp-eval-program
`((require :asdf)
+ ;; Only SBCL supports compression as of 2019-09-02.
+ ,(if (and compress? (string=? (%lisp-type) "sbcl"))
+ '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
+ (uiop:dump-image (asdf:output-file o c)
+ :executable t
+ :compression t))
+ '())
(asdf:operate ',type ,(string-append system "-exec")))))
(define (generate-executable-wrapper-system system dependencies)
@@ -339,6 +346,7 @@ which are not nested."
(dependency-prefixes (list (library-output outputs)))
(dependencies (list (basename program)))
entry-program
+ compress?
#:allow-other-keys)
"Generate an executable program containing all DEPENDENCIES, and which will
execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it
@@ -350,6 +358,7 @@ retained."
#:dependencies dependencies
#:dependency-prefixes dependency-prefixes
#:entry-program entry-program
+ #:compress? compress?
#:type 'asdf:program-op)
(let* ((name (basename program))
(bin-directory (dirname program)))
@@ -382,6 +391,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
dependency-prefixes
entry-program
type
+ compress?
#:allow-other-keys)
"Generate an executable by using asdf operation TYPE, containing whithin the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
@@ -405,7 +415,7 @@ references to those libraries are retained."
`(((,bin-directory :**/ :*.*.*)
(,bin-directory :**/ :*.*.*)))))))
- (generate-executable-for-system type name)
+ (generate-executable-for-system type name #:compress? compress?)
(let* ((after-store-prefix-index
(string-index out-file #\/
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index d30833c5d7..010e0decff 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -75,6 +75,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#:env-vars
`(("bzr url" . ,(bzr-reference-url ref))
("bzr reference" . ,(bzr-reference-revision ref)))
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:local-build? #t ;don't offload repo branching
#:hash-algo hash-algo
diff --git a/guix/ci.scm b/guix/ci.scm
index 1727297dd7..9e21996023 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,9 +18,10 @@
(define-module (guix ci)
#:use-module (guix http-client)
- #:autoload (json parser) (json->scm)
+ #:use-module (guix json)
+ #:use-module (json)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
#:export (build?
build-id
build-derivation
@@ -42,7 +43,7 @@
queued-builds
latest-builds
latest-evaluations
- evaluation-for-commit))
+ evaluations-for-commit))
;;; Commentary:
;;;
@@ -51,28 +52,31 @@
;;;
;;; Code:
-(define-record-type <build>
- (make-build id derivation system status timestamp)
- build?
- (id build-id) ;integer
+(define-json-mapping <build> make-build build?
+ json->build
+ (id build-id "id") ;integer
(derivation build-derivation) ;string | #f
(system build-system) ;string
- (status build-status) ;integer
+ (status build-status "buildstatus" ) ;integer
(timestamp build-timestamp)) ;integer
-(define-record-type <checkout>
- (make-checkout commit input)
- checkout?
+(define-json-mapping <checkout> make-checkout checkout?
+ json->checkout
(commit checkout-commit) ;string (SHA1)
(input checkout-input)) ;string (name)
-(define-record-type <evaluation>
- (make-evaluation id spec complete? checkouts)
- evaluation?
+(define-json-mapping <evaluation> make-evaluation evaluation?
+ json->evaluation
(id evaluation-id) ;integer
(spec evaluation-spec) ;string
- (complete? evaluation-complete?) ;Boolean
- (checkouts evaluation-checkouts)) ;<checkout>*
+ (complete? evaluation-complete? "in-progress"
+ (match-lambda
+ (0 #t)
+ (_ #f))) ;Boolean
+ (checkouts evaluation-checkouts "checkouts" ;<checkout>*
+ (lambda (checkouts)
+ (map json->checkout
+ (vector->list checkouts)))))
(define %query-limit
;; Max number of builds requested in queries.
@@ -84,18 +88,11 @@
(close-port port)
json))
-(define (json->build json)
- (make-build (hash-ref json "id")
- (hash-ref json "derivation")
- (hash-ref json "system")
- (hash-ref json "buildstatus")
- (hash-ref json "timestamp")))
-
(define* (queued-builds url #:optional (limit %query-limit))
"Return the list of queued derivations on URL."
(let ((queue (json-fetch (string-append url "/api/queue?nr="
(number->string limit)))))
- (map json->build queue)))
+ (map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit)
#:key evaluation system)
@@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
(option "system" system)))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
- (map json->build latest)))
-
-(define (json->checkout json)
- (make-checkout (hash-ref json "commit")
- (hash-ref json "input")))
-
-(define (json->evaluation json)
- (make-evaluation (hash-ref json "id")
- (hash-ref json "specification")
- (case (hash-ref json "in-progress")
- ((0) #t)
- (else #f))
- (map json->checkout (hash-ref json "checkouts"))))
+ (map json->build (vector->list latest))))
(define* (latest-evaluations url #:optional (limit %query-limit))
"Return the latest evaluations performed by the CI server at URL."
(map json->evaluation
- (json->scm
- (http-fetch (string-append url "/api/evaluations?nr="
- (number->string limit))))))
+ (vector->list
+ (json->scm
+ (http-fetch (string-append url "/api/evaluations?nr="
+ (number->string limit)))))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 8b46f8ef8c..cb42103aae 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
@@ -92,6 +92,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:hash-algo hash-algo
#:hash hash
diff --git a/guix/git-download.scm b/guix/git-download.scm
index c62bb8ad0f..1eae035fc4 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -157,6 +157,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string
(git-reference-recursive? ref))))
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:local-build? #t ;don't offload repo cloning
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 6b25b87b6b..4cdc1a780a 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
@@ -92,6 +92,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 51c7ea7b2f..35caa3e463 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -230,16 +230,17 @@ from ~s: ~a (~s)~%"
(if (boolean? type) meta
(cons `(bioconductor-type . ,type) meta))))))))))
((git)
- ;; Download the git repository at "NAME"
- (call-with-values
- (lambda () (download name #t))
- (lambda (dir commit)
- (and=> (description->alist (with-input-from-file
- (string-append dir "/DESCRIPTION") read-string))
- (lambda (meta)
- (cons* `(git . ,name)
- `(git-commit . ,commit)
- meta))))))))
+ (and (string-prefix? "http" name)
+ ;; Download the git repository at "NAME"
+ (call-with-values
+ (lambda () (download name #t))
+ (lambda (dir commit)
+ (and=> (description->alist (with-input-from-file
+ (string-append dir "/DESCRIPTION") read-string))
+ (lambda (meta)
+ (cons* `(git . ,name)
+ `(git-commit . ,commit)
+ meta)))))))))
(define (listify meta field)
"Look up FIELD in the alist META. If FIELD contains a comma-separated
@@ -494,12 +495,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
"Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
(let ((description (fetch-description repo package-name)))
- (if (and (not description)
- (eq? repo 'bioconductor))
- ;; Retry import from CRAN
- (cran->guix-package package-name 'cran)
- (and description
- (description->package repo description)))))))
+ (if description
+ (description->package repo description)
+ (case repo
+ ((git)
+ ;; Retry import from Bioconductor
+ (cran->guix-package package-name 'bioconductor))
+ ((bioconductor)
+ ;; Retry import from CRAN
+ (cran->guix-package package-name 'cran))
+ (else #f)))))))
(define* (cran-recursive-import package-name #:optional (repo 'cran))
(recursive-import package-name repo
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 52c5cb1c30..f6057dbf8b 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +23,7 @@
#:use-module ((guix download) #:prefix download:)
#:use-module (gcrypt hash)
#:use-module (guix http-client)
+ #:use-module (guix json)
#:use-module (guix import json)
#:use-module (guix import utils)
#:use-module ((guix licenses) #:prefix license:)
@@ -30,7 +32,7 @@
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (ice-9 match)
- #:use-module (ice-9 pretty-print) ; recursive
+ #:use-module (ice-9 regex)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
@@ -39,46 +41,82 @@
guix-package->crate-name
%crate-updater))
-(define (crate-fetch crate-name callback)
- "Fetch the metadata for CRATE-NAME from crates.io and call the callback."
+
+;;;
+;;; Interface to https://crates.io/api/v1.
+;;;
- (define (crates->inputs crates)
- (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?))
+;; Crates. A crate is essentially a "package". It can have several
+;; "versions", each of which has its own set of dependencies, license,
+;; etc.--see <crate-version> below.
+(define-json-mapping <crate> make-crate crate?
+ json->crate
+ (name crate-name) ;string
+ (latest-version crate-latest-version "max_version") ;string
+ (home-page crate-home-page "homepage") ;string | #nil
+ (repository crate-repository) ;string
+ (description crate-description) ;string
+ (keywords crate-keywords ;list of strings
+ "keywords" vector->list)
+ (categories crate-categories ;list of strings
+ "categories" vector->list)
+ (versions crate-versions "actual_versions" ;list of <crate-version>
+ (lambda (vector)
+ (map json->crate-version
+ (vector->list vector))))
+ (links crate-links)) ;alist
- (define (string->license string)
- (map spdx-string->license (string-split string #\/)))
-
- (define (crate-kind-predicate kind)
- (lambda (dep) (string=? (assoc-ref dep "kind") kind)))
-
- (and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
- (crate (assoc-ref crate-json "crate"))
- (name (assoc-ref crate "name"))
- (version (assoc-ref crate "max_version"))
- (homepage (assoc-ref crate "homepage"))
- (repository (assoc-ref crate "repository"))
- (synopsis (assoc-ref crate "description"))
- (description (assoc-ref crate "description"))
- (license (or (and=> (assoc-ref crate "license")
- string->license)
- '())) ;missing license info
- (path (string-append "/" version "/dependencies"))
- (deps-json (json-fetch (string-append crate-url name path)))
- (deps (vector->list (assoc-ref deps-json "dependencies")))
- (dep-crates (filter (crate-kind-predicate "normal") deps))
- (dev-dep-crates
- (filter (lambda (dep)
- (not ((crate-kind-predicate "normal") dep))) deps))
- (cargo-inputs (crates->inputs dep-crates))
- (cargo-development-inputs (crates->inputs dev-dep-crates))
- (home-page (match homepage
- (() repository)
- (_ homepage))))
- (callback #:name name #:version version
- #:cargo-inputs cargo-inputs
- #:cargo-development-inputs cargo-development-inputs
- #:home-page home-page #:synopsis synopsis
- #:description description #:license license)))
+;; Crate version.
+(define-json-mapping <crate-version> make-crate-version crate-version?
+ json->crate-version
+ (id crate-version-id) ;integer
+ (number crate-version-number "num") ;string
+ (download-path crate-version-download-path "dl_path") ;string
+ (readme-path crate-version-readme-path "readme_path") ;string
+ (license crate-version-license "license") ;string
+ (links crate-version-links)) ;alist
+
+;; Crate dependency. Each dependency (each edge in the graph) is annotated as
+;; being a "normal" dependency or a development dependency. There also
+;; information about the minimum required version, such as "^0.0.41".
+(define-json-mapping <crate-dependency> make-crate-dependency
+ crate-dependency?
+ json->crate-dependency
+ (id crate-dependency-id "crate_id") ;string
+ (kind crate-dependency-kind "kind" ;'normal | 'dev
+ string->symbol)
+ (requirement crate-dependency-requirement "req")) ;string
+
+(define (lookup-crate name)
+ "Look up NAME on https://crates.io and return the corresopnding <crate>
+record or #f if it was not found."
+ (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
+ name))))
+ (and=> (and json (assoc-ref json "crate"))
+ (lambda (alist)
+ ;; The "versions" field of ALIST is simply a list of version IDs
+ ;; (integers). Here, we squeeze in the actual version
+ ;; dictionaries that are not part of ALIST but are just more
+ ;; convenient handled this way.
+ (let ((versions (or (assoc-ref json "versions") '#())))
+ (json->crate `(,@alist
+ ("actual_versions" . ,versions))))))))
+
+(define (crate-version-dependencies version)
+ "Return the list of <crate-dependency> records of VERSION, a
+<crate-version>."
+ (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
+ (url (string-append (%crate-base-url) path)))
+ (match (assoc-ref (or (json-fetch url) '()) "dependencies")
+ ((? vector? vector)
+ (map json->crate-dependency (vector->list vector)))
+ (_
+ '()))))
+
+
+;;;
+;;; Converting crates to Guix packages.
+;;;
(define (maybe-cargo-inputs package-names)
(match (package-names->package-inputs package-names)
@@ -138,10 +176,49 @@ and LICENSE."
(close-port port)
pkg))
+(define %dual-license-rx
+ ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0".
+ ;; This regexp matches that.
+ (make-regexp "^(.*) OR (.*)$"))
+
(define (crate->guix-package crate-name)
"Fetch the metadata for CRATE-NAME from crates.io, and return the
`package' s-expression corresponding to that package, or #f on failure."
- (crate-fetch crate-name make-crate-sexp))
+ (define (string->license string)
+ (match (regexp-exec %dual-license-rx string)
+ (#f (list (spdx-string->license string)))
+ (m (list (spdx-string->license (match:substring m 1))
+ (spdx-string->license (match:substring m 2))))))
+
+ (define (normal-dependency? dependency)
+ (eq? (crate-dependency-kind dependency) 'normal))
+
+ (define crate
+ (lookup-crate crate-name))
+
+ (and crate
+ (let* ((version (find (lambda (version)
+ (string=? (crate-version-number version)
+ (crate-latest-version crate)))
+ (crate-versions crate)))
+ (dependencies (crate-version-dependencies version))
+ (dep-crates (filter normal-dependency? dependencies))
+ (dev-dep-crates (remove normal-dependency? dependencies))
+ (cargo-inputs (sort (map crate-dependency-id dep-crates)
+ string-ci<?))
+ (cargo-development-inputs
+ (sort (map crate-dependency-id dev-dep-crates)
+ string-ci<?)))
+ (make-crate-sexp #:name crate-name
+ #:version (crate-version-number version)
+ #:cargo-inputs cargo-inputs
+ #:cargo-development-inputs cargo-development-inputs
+ #:home-page (or (crate-home-page crate)
+ (crate-repository crate))
+ #:synopsis (crate-description crate)
+ #:description (crate-description crate)
+ #:license (and=> (crate-version-license version)
+ string->license)))))
(define (guix-package->crate-name package)
"Return the crate name of PACKAGE."
@@ -157,6 +234,7 @@ and LICENSE."
(define (crate-name->package-name name)
(string-append "rust-" (string-join (string-split name #\_) "-")))
+
;;;
;;; Updater
;;;
@@ -175,9 +253,9 @@ and LICENSE."
(define (latest-release package)
"Return an <upstream-source> for the latest release of PACKAGE."
(let* ((crate-name (guix-package->crate-name package))
- (callback (lambda* (#:key version #:allow-other-keys) version))
- (version (crate-fetch crate-name callback))
- (url (crate-uri crate-name version)))
+ (crate (lookup-crate crate-name))
+ (version (crate-latest-version crate))
+ (url (crate-uri crate-name version)))
(upstream-source
(package (package-name package))
(version version)
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index 5dcc0e97a3..7f089a5cf3 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -238,7 +238,9 @@ path to the repository."
(version (find-latest-version name repository))
(file (string-append repository "/packages/" name "/" name "." version "/opam")))
`(("metadata" ,@(get-metadata file))
- ("version" . ,version))))
+ ("version" . ,(if (string-prefix? "v" version)
+ (substring version 1)
+ version)))))
(define (opam->guix-package name)
(and-let* ((opam-file (opam-fetch name))
@@ -283,7 +285,7 @@ path to the repository."
'ocaml-build-system))
,@(if (null? inputs)
'()
- `((inputs ,(list 'quasiquote inputs))))
+ `((propagated-inputs ,(list 'quasiquote inputs))))
,@(if (null? native-inputs)
'()
`((native-inputs ,(list 'quasiquote native-inputs))))
diff --git a/guix/json.scm b/guix/json.scm
new file mode 100644
index 0000000000..20f0bd8f13
--- /dev/null
+++ b/guix/json.scm
@@ -0,0 +1,62 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix json)
+ #:use-module (json)
+ #:use-module (srfi srfi-9)
+ #:export (define-json-mapping))
+
+;;; Commentary:
+;;;
+;;; Helpers to map JSON objects to SRFI-9 records. Taken from (guix swh).
+;;;
+;;; Code:
+
+(define-syntax-rule (define-json-reader json->record ctor spec ...)
+ "Define JSON->RECORD as a procedure that converts a JSON representation,
+read from a port, string, or hash table, into a record created by CTOR and
+following SPEC, a series of field specifications."
+ (define (json->record input)
+ (let ((table (cond ((port? input)
+ (json->scm input))
+ ((string? input)
+ (json-string->scm input))
+ ((or (null? input) (pair? input))
+ input))))
+ (let-syntax ((extract-field (syntax-rules ()
+ ((_ table (field key json->value))
+ (json->value (assoc-ref table key)))
+ ((_ table (field key))
+ (assoc-ref table key))
+ ((_ table (field))
+ (assoc-ref table
+ (symbol->string 'field))))))
+ (ctor (extract-field table spec) ...)))))
+
+(define-syntax-rule (define-json-mapping rtd ctor pred json->record
+ (field getter spec ...) ...)
+ "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
+and define JSON->RECORD as a conversion from JSON to a record of this type."
+ (begin
+ (define-record-type rtd
+ (ctor field ...)
+ pred
+ (field getter) ...)
+
+ (define-json-reader json->record ctor
+ (field spec ...) ...)))
diff --git a/guix/lint.scm b/guix/lint.scm
index 212ff70d54..ba38bef806 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -44,6 +44,8 @@
#:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
#:use-module (guix gnu-maintenance)
#:use-module (guix cve)
+ #:use-module ((guix swh) #:hide (origin?))
+ #:autoload (guix git-download) (git-reference?)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -80,6 +82,7 @@
check-vulnerabilities
check-for-updates
check-formatting
+ check-archival
lint-warning
lint-warning?
@@ -950,6 +953,16 @@ display a message including MESSAGE and return ERROR-VALUE."
message
(tls-certificate-error-string args))
error-value)
+ ((and ('system-error _ ...) args)
+ (let ((errno (system-error-errno args)))
+ (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
+ (let ((details (call-with-output-string
+ (lambda (port)
+ (print-exception port #f (car args)
+ (cdr args))))))
+ (warning (G_ "~a: ~a~%") message details)
+ error-value)
+ (apply throw args))))
(args
(apply throw args))))))
@@ -1023,6 +1036,93 @@ the NIST server non-fatal."
'()))
(#f '()))) ; cannot find newer upstream release
+
+(define (check-archival package)
+ "Check whether PACKAGE's source code is archived on Software Heritage. If
+it's not, and if its source code is a VCS snapshot, then send a \"save\"
+request to Software Heritage.
+
+Software Heritage imposes limits on the request rate per client IP address.
+This checker prints a notice and stops doing anything once that limit has been
+reached."
+ (define (response->warning url method response)
+ (if (request-rate-limit-reached? url method)
+ (list (make-warning package
+ (G_ "Software Heritage rate limit reached; \
+try again later")
+ #:field 'source))
+ (list (make-warning package
+ (G_ "'~a' returned ~a")
+ (list url (response-code response))
+ #:field 'source))))
+
+ (define skip-key (gensym "skip-archival-check"))
+
+ (define (skip-when-limit-reached url method)
+ (or (not (request-rate-limit-reached? url method))
+ (throw skip-key #t)))
+
+ (parameterize ((%allow-request? skip-when-limit-reached))
+ (catch #t
+ (lambda ()
+ (match (and (origin? (package-source package))
+ (package-source package))
+ (#f ;no source
+ '())
+ ((= origin-uri (? git-reference? reference))
+ (define url
+ (git-reference-url reference))
+ (define commit
+ (git-reference-commit reference))
+
+ (match (if (commit-id? commit)
+ (or (lookup-revision commit)
+ (lookup-origin-revision url commit))
+ (lookup-origin-revision url commit))
+ ((? revision? revision)
+ '())
+ (#f
+ ;; Revision is missing from the archive, attempt to save it.
+ (catch 'swh-error
+ (lambda ()
+ (save-origin (git-reference-url reference) "git")
+ (list (make-warning
+ package
+ ;; TRANSLATORS: "Software Heritage" is a proper noun
+ ;; that must remain untranslated. See
+ ;; <https://www.softwareheritage.org>.
+ (G_ "scheduled Software Heritage archival")
+ #:field 'source)))
+ (lambda (key url method response . _)
+ (cond ((= 429 (response-code response))
+ (list (make-warning
+ package
+ (G_ "archival rate limit exceeded; \
+try again later")
+ #:field 'source)))
+ (else
+ (response->warning url method response))))))))
+ ((? origin? origin)
+ ;; Since "save" origins are not supported for non-VCS source, all
+ ;; we can do is tell whether a given tarball is available or not.
+ (if (origin-sha256 origin) ;XXX: for ungoogled-chromium
+ (match (lookup-content (origin-sha256 origin) "sha256")
+ (#f
+ (list (make-warning package
+ (G_ "source not archived on Software \
+Heritage")
+ #:field 'source)))
+ ((? content?)
+ '()))
+ '()))))
+ (match-lambda*
+ ((key url method response)
+ (response->warning url method response))
+ ((key . args)
+ (if (eq? key skip-key)
+ '()
+ (apply throw key args)))))))
+
;;;
;;; Source code formatting.
@@ -1031,7 +1131,7 @@ the NIST server non-fatal."
(define (report-tabulations package line line-number)
"Warn about tabulations found in LINE."
(match (string-index line #\tab)
- (#f #t)
+ (#f #f)
(index
(make-warning package
(G_ "tabulation on line ~a, column ~a")
@@ -1043,44 +1143,44 @@ the NIST server non-fatal."
(define (report-trailing-white-space package line line-number)
"Warn about trailing white space in LINE."
- (unless (or (string=? line (string-trim-right line))
- (string=? line (string #\page)))
- (make-warning package
- (G_ "trailing white space on line ~a")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
+ (and (not (or (string=? line (string-trim-right line))
+ (string=? line (string #\page))))
+ (make-warning package
+ (G_ "trailing white space on line ~a")
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define (report-long-line package line line-number)
"Emit a warning if LINE is too long."
;; Note: We don't warn at 80 characters because sometimes hashes and URLs
;; make it hard to fit within that limit and we want to avoid making too
;; much noise.
- (when (> (string-length line) 90)
- (make-warning package
- (G_ "line ~a is way too long (~a characters)")
- (list line-number (string-length line))
- #:location
- (location (package-file package)
- line-number
- 0))))
+ (and (> (string-length line) 90)
+ (make-warning package
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %hanging-paren-rx
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
- (when (regexp-exec %hanging-paren-rx line)
- (make-warning package
- (G_ "parentheses feel lonely, \
+ (and (regexp-exec %hanging-paren-rx line)
+ (make-warning package
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1130,11 +1230,9 @@ them for PACKAGE."
warnings
(if (< line-number starting-line)
'()
- (filter
- lint-warning?
- (map (lambda (report)
- (report package line line-number))
- reporters))))))))))))
+ (filter-map (lambda (report)
+ (report package line line-number))
+ reporters)))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
@@ -1229,7 +1327,11 @@ or a list thereof")
(lint-checker
(name 'refresh)
(description "Check the package for new upstream releases")
- (check check-for-updates))))
+ (check check-for-updates))
+ (lint-checker
+ (name 'archival)
+ (description "Ensure source code archival on Software Heritage")
+ (check check-archival))))
(define %all-checkers
(append %local-checkers
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 329de41143..cf571756fd 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -66,11 +66,15 @@ Perform the deployment specified by FILE.\n"))
%standard-build-options))
(define %default-options
- `((substitutes? . #t)
- (build-hook? . #t)
- (graft? . #t)
+ ;; Alist of default option values.
+ `((verbosity . 1)
(debug . 0)
- (verbosity . 1)))
+ (graft? . #t)
+ (substitutes? . #t)
+ (build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)))
(define (load-source-file file)
"Load FILE as a user module."
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9fc3a10e98..27b014db68 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -384,12 +384,14 @@ STORE is an open connection to the store."
(bootloader bootloader)))
;; Make the specified system generation the default entry.
- (params (profile-boot-parameters %system-profile (list number)))
+ (params (first (profile-boot-parameters %system-profile
+ (list number))))
(old-generations
(delv number (reverse (generation-numbers %system-profile))))
(old-params (profile-boot-parameters
%system-profile old-generations))
- (entries (map boot-parameters->menu-entry params))
+ (entries (cons (boot-parameters->menu-entry params)
+ (boot-parameters-bootloader-menu-entries params)))
(old-entries (map boot-parameters->menu-entry old-params)))
(run-with-store store
(mlet* %store-monad
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 5c25437059..4139cbc2e2 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -131,6 +131,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:hash-algo hash-algo
#:hash hash
diff --git a/guix/swh.scm b/guix/swh.scm
index c253e217da..7acad05928 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -20,6 +20,8 @@
#:use-module (guix base16)
#:use-module (guix build utils)
#:use-module ((guix build syscalls) #:select (mkdtemp!))
+ #:use-module (web uri)
+ #:use-module (guix json)
#:use-module (web client)
#:use-module (web response)
#:use-module (json)
@@ -32,6 +34,9 @@
#:use-module (ice-9 popen)
#:use-module ((ice-9 ftw) #:select (scandir))
#:export (%swh-base-url
+ %allow-request?
+
+ request-rate-limit-reached?
origin?
origin-id
@@ -101,6 +106,8 @@
request-cooking
vault-fetch
+ commit-id?
+
swh-download))
;;; Commentary:
@@ -129,40 +136,6 @@
url
(string-append url "/")))
-(define-syntax-rule (define-json-reader json->record ctor spec ...)
- "Define JSON->RECORD as a procedure that converts a JSON representation,
-read from a port, string, or hash table, into a record created by CTOR and
-following SPEC, a series of field specifications."
- (define (json->record input)
- (let ((table (cond ((port? input)
- (json->scm input))
- ((string? input)
- (json-string->scm input))
- ((or (null? input) (pair? input))
- input))))
- (let-syntax ((extract-field (syntax-rules ()
- ((_ table (field key json->value))
- (json->value (assoc-ref table key)))
- ((_ table (field key))
- (assoc-ref table key))
- ((_ table (field))
- (assoc-ref table
- (symbol->string 'field))))))
- (ctor (extract-field table spec) ...)))))
-
-(define-syntax-rule (define-json-mapping rtd ctor pred json->record
- (field getter spec ...) ...)
- "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
-and define JSON->RECORD as a conversion from JSON to a record of this type."
- (begin
- (define-record-type rtd
- (ctor field ...)
- pred
- (field getter) ...)
-
- (define-json-reader json->record ctor
- (field spec ...) ...)))
-
(define %date-regexp
;; Match strings like "2014-11-17T22:09:38+01:00" or
;; "2018-09-30T23:20:07.815449+00:00"".
@@ -196,31 +169,71 @@ Software Heritage."
((? string? str) str)
((? null?) #f)))
+(define %allow-request?
+ ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true
+ ;; to keep going. This can be used to disallow a requests when
+ ;; 'request-rate-limit-reached?' returns true, for instance.
+ (make-parameter (const #t)))
+
+;; The time when the rate limit for "/origin/save" POST requests and that of
+;; other requests will be reset.
+;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
+(define %save-rate-limit-reset-time 0)
+(define %general-rate-limit-reset-time 0)
+
+(define (request-rate-limit-reached? url method)
+ "Return true if the rate limit has been reached for URI."
+ (define uri
+ (string->uri url))
+
+ (define reset-time
+ (if (and (eq? method http-post)
+ (string-prefix? "/api/1/origin/save/" (uri-path uri)))
+ %save-rate-limit-reset-time
+ %general-rate-limit-reset-time))
+
+ (< (car (gettimeofday)) reset-time))
+
+(define (update-rate-limit-reset-time! url method response)
+ "Update the rate limit reset time for URL and METHOD based on the headers in
+RESPONSE."
+ (let ((uri (string->uri url)))
+ (match (assq-ref (response-headers response) 'x-ratelimit-reset)
+ ((= string->number (? number? reset))
+ (if (and (eq? method http-post)
+ (string-prefix? "/api/1/origin/save/" (uri-path uri)))
+ (set! %save-rate-limit-reset-time reset)
+ (set! %general-rate-limit-reset-time reset)))
+ (_
+ #f))))
+
(define* (call url decode #:optional (method http-get)
#:key (false-if-404? #t))
"Invoke the endpoint at URL using METHOD. Decode the resulting JSON body
using DECODE, a one-argument procedure that takes an input port. When
FALSE-IF-404? is true, return #f upon 404 responses."
- (let*-values (((response port)
- (method url #:streaming? #t)))
- ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
- (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
- (#f #t)
- ((? (compose zero? string->number))
- (throw 'swh-error url response))
- (_ #t))
-
- (cond ((= 200 (response-code response))
- (let ((result (decode port)))
- (close-port port)
- result))
- ((and false-if-404?
- (= 404 (response-code response)))
- (close-port port)
- #f)
- (else
- (close-port port)
- (throw 'swh-error url response)))))
+ (and ((%allow-request?) url method)
+ (let*-values (((response port)
+ (method url #:streaming? #t)))
+ ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
+ (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
+ (#f #t)
+ ((? (compose zero? string->number))
+ (update-rate-limit-reset-time! url method response)
+ (throw 'swh-error url method response))
+ (_ #t))
+
+ (cond ((= 200 (response-code response))
+ (let ((result (decode port)))
+ (close-port port)
+ result))
+ ((and false-if-404?
+ (= 404 (response-code response)))
+ (close-port port)
+ #f)
+ (else
+ (close-port port)
+ (throw 'swh-error url method response))))))
(define-syntax define-query
(syntax-rules (path)
@@ -524,7 +537,7 @@ requested bundle cooking, waiting for completion...~%"))
(define (commit-id? reference)
"Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
-it is a tag name."
+it is a tag name. This is based on a simple heuristic so use with care!"
(and (= (string-length reference) 40)
(string-every char-set:hex-digit reference)))
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index a56d6f213d..05ce39bca2 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +22,7 @@
#:use-module (web server http)
#:use-module (web response)
#:use-module (srfi srfi-39)
+ #:use-module (ice-9 match)
#:export (with-http-server
call-with-http-server
%http-server-port
@@ -69,10 +70,20 @@ needed."
(string-append "http://localhost:" (number->string (%http-server-port))
"/foo/bar"))
-(define* (call-with-http-server code data thunk
- #:key (headers '()))
- "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
+(define* (call-with-http-server responses+data thunk)
+ "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
+requests. Each elements of RESPONSES+DATA must be a tuple containing a
+response and a string, or an HTTP response code and a string."
+ (define responses
+ (map (match-lambda
+ (((? response? response) data)
+ (list response data))
+ (((? integer? code) data)
+ (list (build-response #:code code
+ #:reason-phrase "Such is life")
+ data)))
+ responses+data))
+
(define (http-write server client response body)
"Write RESPONSE."
(let* ((response (write-response response client))
@@ -82,7 +93,8 @@ string) on HTTP requests."
(else
(write-response-body response body)))
(close-port port)
- (quit #t) ;exit the server thread
+ (when (null? responses)
+ (quit #t)) ;exit the server thread
(values)))
;; Mutex and condition variable to synchronize with the HTTP server.
@@ -105,10 +117,10 @@ string) on HTTP requests."
(define (server-body)
(define (handle request body)
- (values (build-response #:code code
- #:reason-phrase "Such is life"
- #:headers headers)
- data))
+ (match responses
+ (((response data) rest ...)
+ (set! responses rest)
+ (values response data))))
(let ((socket (open-http-server-socket)))
(catch 'quit
@@ -126,10 +138,7 @@ string) on HTTP requests."
(define-syntax with-http-server
(syntax-rules ()
- ((_ (code headers) data body ...)
- (call-with-http-server code data (lambda () body ...)
- #:headers headers))
- ((_ code data body ...)
- (call-with-http-server code data (lambda () body ...)))))
+ ((_ responses+data body ...)
+ (call-with-http-server responses+data (lambda () body ...)))))
;;; http.scm ends here
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-17 12:00:00 +0000