diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/ant.scm | 6 | ||||
| -rw-r--r-- | guix/build/ant-build-system.scm | 38 | ||||
| -rw-r--r-- | guix/build/pull.scm | 3 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 1 | ||||
| -rw-r--r-- | guix/download.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 65 | ||||
| -rw-r--r-- | guix/store.scm | 1 | ||||
| -rw-r--r-- | guix/upstream.scm | 18 |
13 files changed, 161 insertions, 38 deletions
diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index e0870a605c..b5626bd42d 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -99,6 +99,9 @@ (make-flags ''()) (build-target "jar") (jar-name #f) + (main-class #f) + (test-include (list "**/*Test.java")) + (test-exclude (list "**/Abstract*.java")) (source-dir "src") (test-dir "src/test") (phases '(@ (guix build ant-build-system) @@ -130,6 +133,9 @@ #:test-target ,test-target #:build-target ,build-target #:jar-name ,jar-name + #:main-class ,main-class + #:test-include (list ,@test-include) + #:test-exclude (list ,@test-exclude) #:source-dir ,source-dir #:test-dir ,test-dir #:phases ,phases diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 4042630a10..a440daf054 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -36,7 +36,9 @@ ;; Code: (define* (default-build.xml jar-name prefix #:optional - (source-dir ".") (test-dir "./test")) + (source-dir ".") (test-dir "./test") (main-class #f) + (test-include '("**/*Test.java")) + (test-exclude '("**/Abstract*Test.java"))) "Create a simple build.xml with standard targets for Ant." (call-with-output-file "build.xml" (lambda (port) @@ -44,6 +46,10 @@ `(project (@ (basedir ".")) (property (@ (name "classes.dir") (value "${basedir}/build/classes"))) + (property (@ (name "manifest.dir") + (value "${basedir}/build/manifest"))) + (property (@ (name "manifest.file") + (value "${manifest.dir}/MANIFEST.MF"))) (property (@ (name "jar.dir") (value "${basedir}/build/jar"))) (property (@ (name "dist.dir") @@ -60,6 +66,17 @@ (path (@ (id "classpath")) (pathelement (@ (location "${env.CLASSPATH}")))) + (target (@ (name "manifest")) + (mkdir (@ (dir "${manifest.dir}"))) + (echo (@ (file "${manifest.file}") + (message ,(string-append + (if main-class + (string-append + "Main-Class: " main-class + "${line.separator}") + "") + ""))))) + (target (@ (name "compile")) (mkdir (@ (dir "${classes.dir}"))) (javac (@ (includeantruntime "false") @@ -94,13 +111,19 @@ (batchtest (@ (fork "yes") (todir "${test.home}/test-reports")) (fileset (@ (dir "${test.home}/java")) - (include (@ (name "**/*Test.java" ))))))) + ,@(map (lambda (file) + `(include (@ (name ,file)))) + test-include) + ,@(map (lambda (file) + `(exclude (@ (name ,file)))) + test-exclude))))) (target (@ (name "jar") - (depends "compile")) + (depends "compile, manifest")) (mkdir (@ (dir "${jar.dir}"))) (exec (@ (executable "jar")) - (arg (@ (line ,(string-append "-cf ${jar.dir}/" jar-name + (arg (@ (line ,(string-append "-cmf ${manifest.file} " + "${jar.dir}/" jar-name " -C ${classes.dir} .")))))) (target (@ (name "install")) @@ -133,12 +156,15 @@ to the default GNU unpack strategy." (define* (configure #:key inputs outputs (jar-name #f) (source-dir "src") - (test-dir "src/test") #:allow-other-keys) + (test-dir "src/test") + (main-class #f) + (test-include '("**/*Test.java")) + (test-exclude '("**/Abstract*.java")) #:allow-other-keys) (when jar-name (default-build.xml jar-name (string-append (assoc-ref outputs "out") "/share/java") - source-dir test-dir)) + source-dir test-dir main-class test-include test-exclude)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) (setenv "CLASSPATH" (generate-classpath inputs))) diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 03b0f925a7..1ae35ab382 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -178,7 +178,8 @@ containing the source code. Write any debugging output to DEBUG-PORT." ;; Make sure compilation related modules are loaded before starting to ;; compile files in parallel. (compile #f) - (par-for-each + (n-par-for-each + (parallel-job-count) (lambda (file) (with-mutex mutex (display #\cr log-port) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 55b0df3911..e5779cbd0b 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -773,6 +773,7 @@ Turning finalization off shuts down the finalization thread as a side effect." ("x86_64" 56) ("mips64" 5055) ("armv7l" 120) + ("aarch64" 220) (_ #f)))) (lambda (flags) "Create a new child process by duplicating the current parent process. diff --git a/guix/download.scm b/guix/download.scm index a1560de1a1..449521c199 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -235,6 +235,7 @@ "http://archive.debian.org/debian/") (kde "http://download.kde.org" + "http://download.kde.org/Attic" ; for when it gets archived. ;; Mirrors from http://files.kde.org/extra/mirrors.html ;; Europe "http://mirror.easyname.at/kde" diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 57bbeec465..fc61f0b547 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -33,6 +33,7 @@ #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix ui) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix scripts) @@ -73,6 +74,7 @@ check-mirror-url check-license check-vulnerabilities + check-for-updates check-formatting run-checkers @@ -826,6 +828,17 @@ from ~s: ~a (~s)~%") (string-join (map vulnerability-id unpatched) ", "))))))))) +(define (check-for-updates package) + "Check if there is an update available for PACKAGE." + (match (package-latest-release* package (force %updaters)) + ((? upstream-source? source) + (when (version>? (upstream-source-version source) + (package-version package)) + (emit-warning package + (format #f (G_ "can be upgraded to ~a") + (upstream-source-version source))))) + (#f #f))) ; cannot find newer upstream release + ;;; ;;; Source code formatting. @@ -992,6 +1005,10 @@ or a list thereof") (CVE) database") (check check-vulnerabilities)) (lint-checker + (name 'refresh) + (description "Check the package for new upstream releases") + (check check-for-updates)) + (lint-checker (name 'formatting) (description "Look for formatting issues in the source") (check check-formatting)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4adc705220..0e365018a9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -604,12 +604,12 @@ and upgrades." (options->upgrade-predicate opts)) (define upgraded - (fold (lambda (entry transaction) - (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) - transaction)) - transaction - (manifest-entries manifest))) + (fold-right (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ade3c49a54..dd54f03996 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -484,9 +484,11 @@ requested using POOL." #:buffer-size (* 128 1024)) (rename-file (string-append nar ".tmp") nar)) ('none - ;; When compression is disabled, we retrieve files directly from the - ;; store; no need to cache them. - #t)) + ;; Cache nars even when compression is disabled so that we can + ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.) + (with-atomic-file-output nar + (lambda (port) + (write-file item port))))) (mkdir-p (dirname narinfo)) (with-atomic-file-output narinfo @@ -788,8 +790,11 @@ blocking." ;; /nar/<store-item> ((components ... store-item) (if (nar-path? components) - (render-nar store request store-item - #:compression %no-compression) + (if cache + (render-nar/cached store cache request store-item + #:compression %no-compression) + (render-nar store request store-item + #:compression %no-compression)) (not-found request))) (x (not-found request))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index b1c87c870e..2400198000 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -82,7 +82,7 @@ Install it by running: (resolve-interface '(git)))) (define %repository-url - "https://git.savannah.gnu.org/git/guix.git") + (or (getenv "GUIX_PULL_URL") "https://git.savannah.gnu.org/git/guix.git")) ;;; diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 5add64d8e8..d638d744af 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -30,7 +30,6 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix upstream) - #:use-module (guix discovery) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix monads) @@ -46,8 +45,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 binary-ports) - #:export (guix-refresh - %updaters)) + #:export (guix-refresh)) ;;; @@ -162,22 +160,6 @@ specified with `--select'.\n")) ;;; Updates. ;;; -(define (importer-modules) - "Return the list of importer modules." - (cons (resolve-interface '(guix gnu-maintenance)) - (all-modules (map (lambda (entry) - `(,entry . "guix/import")) - %load-path)))) - -(define %updaters - ;; The list of publically-known updaters. - (delay (fold-module-public-variables (lambda (obj result) - (if (upstream-updater? obj) - (cons obj result) - result)) - '() - (importer-modules)))) - (define (lookup-updater-by-name name) "Return the updater called NAME." (or (find (lambda (updater) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 567d8bb643..e50f1d8ac7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -37,6 +37,8 @@ #:use-module (guix scripts graph) #:use-module (guix build utils) #:use-module (gnu build install) + #:autoload (gnu build file-systems) + (find-partition-by-label find-partition-by-uuid) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -404,6 +406,7 @@ NUMBERS, which is a list of generation numbers." "Roll back the system profile to its previous generation. STORE is an open connection to the store." (switch-to-system-generation store "-1")) + ;;; ;;; Switch generations. @@ -556,6 +559,61 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." ;;; +;;; File system declaration checks. +;;; + +(define (check-file-system-availability file-systems) + "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if +any, are available. Raise an error if they're not." + (define relevant + (filter (lambda (fs) + (and (file-system-mount? fs) + (not (string=? "tmpfs" (file-system-type fs))) + (not (memq 'bind-mount (file-system-flags fs))))) + file-systems)) + + (define labeled + (filter (lambda (fs) + (eq? (file-system-title fs) 'label)) + relevant)) + + (define uuid + (filter (lambda (fs) + (eq? (file-system-title fs) 'uuid)) + relevant)) + + (define fail? #f) + + (define (file-system-location* fs) + (location->string + (source-properties->location + (file-system-location fs)))) + + (let-syntax ((error (syntax-rules () + ((_ args ...) + (begin + (set! fail? #t) + (format (current-error-port) + args ...)))))) + (for-each (lambda (fs) + (unless (find-partition-by-label (file-system-device fs)) + (error (G_ "~a: error: file system with label '~a' not found~%") + (file-system-location* fs) + (file-system-device fs)))) + labeled) + (for-each (lambda (fs) + (unless (find-partition-by-uuid (file-system-device fs)) + (error (G_ "~a: error: file system with UUID '~a' not found~%") + (file-system-location* fs) + (uuid->string (file-system-device fs))))) + uuid) + + (when fail? + ;; Better be safe than sorry. + (exit 1)))) + + +;;; ;;; Action. ;;; @@ -637,6 +695,13 @@ output when building a system derivation, such as a disk image." (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull)) + ;; Check whether the declared file systems exist. This is better than + ;; instantiating a broken configuration. Assume that we can only check if + ;; running as root. + (when (and (memq action '(init reconfigure)) + (zero? (getuid))) + (check-file-system-availability (operating-system-file-systems os))) + (mlet* %store-monad ((sys (system-derivation-for-action os action #:file-system-type file-system-type diff --git a/guix/store.scm b/guix/store.scm index d571122021..f336df85cc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -41,6 +41,7 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 popen) #:use-module (ice-9 threads) + #:use-module (ice-9 format) #:use-module (web uri) #:export (%daemon-socket-uri %gc-roots-directory diff --git a/guix/upstream.scm b/guix/upstream.scm index 6ad52ac960..0fe3308876 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -20,6 +20,7 @@ (define-module (guix upstream) #:use-module (guix records) #:use-module (guix utils) + #:use-module (guix discovery) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix gnupg) @@ -55,6 +56,7 @@ upstream-updater-predicate upstream-updater-latest + %updaters lookup-updater download-tarball @@ -146,6 +148,22 @@ correspond to the same version." (pred upstream-updater-predicate) (latest upstream-updater-latest)) +(define (importer-modules) + "Return the list of importer modules." + (cons (resolve-interface '(guix gnu-maintenance)) + (all-modules (map (lambda (entry) + `(,entry . "guix/import")) + %load-path)))) + +(define %updaters + ;; The list of publically-known updaters. + (delay (fold-module-public-variables (lambda (obj result) + (if (upstream-updater? obj) + (cons obj result) + result)) + '() + (importer-modules)))) + (define (lookup-updater package updaters) "Return an updater among UPDATERS that matches PACKAGE, or #f if none of them matches." |