diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/ci.scm | 78 | ||||
| -rw-r--r-- | guix/docker.scm | 200 | ||||
| -rw-r--r-- | guix/gexp.scm | 51 | ||||
| -rw-r--r-- | guix/git.scm | 7 | ||||
| -rw-r--r-- | guix/modules.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 16 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 38 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 73 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 109 |
12 files changed, 468 insertions, 131 deletions
diff --git a/guix/ci.scm b/guix/ci.scm new file mode 100644 index 0000000000..881f3d3927 --- /dev/null +++ b/guix/ci.scm @@ -0,0 +1,78 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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 ci) + #:use-module (guix http-client) + #:autoload (json parser) (json->scm) + #:use-module (srfi srfi-9) + #:export (build? + build-id + build-derivation + build-system + build-status + build-timestamp + + %query-limit + queued-builds + latest-builds)) + +;;; Commentary: +;;; +;;; This module provides a client to the HTTP interface of the Hydra and +;;; Cuirass continuous integration (CI) tools. +;;; +;;; Code: + +(define-record-type <build> + (make-build id derivation system status timestamp) + build? + (id build-id) ;integer + (derivation build-derivation) ;string | #f + (system build-system) ;string + (status build-status) ;integer + (timestamp build-timestamp)) ;integer + +(define %query-limit + ;; Max number of builds requested in queries. + 1000) + +(define (json-fetch url) + (let* ((port (http-fetch url)) + (json (json->scm port))) + (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))) + +(define* (latest-builds url #:optional (limit %query-limit)) + (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr=" + (number->string limit))))) + ;; Note: Hydra does not provide a "derivation" field for entries in + ;; 'latestbuilds', but Cuirass does. + (map json->build latest))) diff --git a/guix/docker.scm b/guix/docker.scm index 060232148e..a75534c33b 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,9 +24,12 @@ #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively - with-directory-excursion)) - #:use-module (guix build store-copy) + with-directory-excursion + invoke)) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module ((texinfo string-utils) + #:select (escape-special-chars)) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (build-docker-image)) @@ -33,8 +37,7 @@ ;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co. (module-use! (current-module) (resolve-interface '(json))) -;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image -;; containing the closure at PATH. +;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. (define docker-id (compose bytevector->base16-string sha256 string->utf8)) @@ -102,82 +105,123 @@ return \"a\"." ((first rest ...) first))) -(define* (build-docker-image image path - #:key closure compressor +(define* (build-docker-image image paths prefix + #:key (symlinks '()) + (transformations '()) (system (utsname:machine (uname))) + compressor (creation-time (current-time time-utc))) - "Write to IMAGE a Docker image archive from the given store PATH. The image -contains the closure of PATH, as specified in CLOSURE (a file produced by -#:references-graphs). SYMLINKS must be a list of (SOURCE -> TARGET) tuples -describing symlinks to be created in the image, where each TARGET is relative -to PATH. SYSTEM is a GNU triplet (or prefix thereof) of the system the -binaries at PATH are for; it is used to produce metadata in the image. - -Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use -CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata." - (let ((directory "/tmp/docker-image") ;temporary working directory - (closure (canonicalize-path closure)) - (id (docker-id path)) - (time (date->string (time-utc->date creation-time) "~4")) - (arch (let-syntax ((cond* (syntax-rules () - ((_ (pattern clause) ...) - (cond ((string-prefix? pattern system) - clause) - ... - (else - (error "unsupported system" - system))))))) - (cond* ("x86_64" "amd64") - ("i686" "386") - ("arm" "arm") - ("mips64" "mips64le"))))) + "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX +must be a store path that is a prefix of any store paths in PATHS. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be +created in the image, where each TARGET is relative to PREFIX. +TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to +transform the PATHS. Any path in PATHS that begins with OLD will be rewritten +in the Docker image so that it begins with NEW instead. If a path is a +non-empty directory, then its contents will be recursively added, as well. + +SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in +PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a +command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a +SRFI-19 time-utc object, as the creation time in metadata." + (define (sanitize path-fragment) + (escape-special-chars + ;; GNU tar strips the leading slash off of absolute paths before applying + ;; the transformations, so we need to do the same, or else our + ;; replacements won't match any paths. + (string-trim path-fragment #\/) + ;; Escape the basic regexp special characters (see: "(sed) BRE syntax"). + ;; We also need to escape "/" because we use it as a delimiter. + "/*.^$[]\\" + #\\)) + (define transformation->replacement + (match-lambda + ((old '-> new) + ;; See "(tar) transform" for details on the expression syntax. + (string-append "s/^" (sanitize old) "/" (sanitize new) "/")))) + (define (transformations->expression transformations) + (let ((replacements (map transformation->replacement transformations))) + (string-append + ;; Avoid transforming link targets, since that would break some links + ;; (e.g., symlinks that point to an absolute store path). + "flags=rSH;" + (string-join replacements ";") + ;; Some paths might still have a leading path delimiter even after tar + ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so + ;; strip any leading path delimiters that remain. + ";s,^//*,,"))) + (define transformation-options + (if (eq? '() transformations) + '() + `("--transform" ,(transformations->expression transformations)))) + (let* ((directory "/tmp/docker-image") ;temporary working directory + (id (docker-id prefix)) + (time (date->string (time-utc->date creation-time) "~4")) + (arch (let-syntax ((cond* (syntax-rules () + ((_ (pattern clause) ...) + (cond ((string-prefix? pattern system) + clause) + ... + (else + (error "unsupported system" + system))))))) + (cond* ("x86_64" "amd64") + ("i686" "386") + ("arm" "arm") + ("mips64" "mips64le"))))) ;; Make sure we start with a fresh, empty working directory. (mkdir directory) - - (and (with-directory-excursion directory - (mkdir id) - (with-directory-excursion id - (with-output-to-file "VERSION" - (lambda () (display schema-version))) - (with-output-to-file "json" - (lambda () (scm->json (image-description id time)))) - - ;; Wrap it up. - (let ((items (call-with-input-file closure - read-reference-graph))) - ;; Create SYMLINKS. - (for-each (match-lambda - ((source '-> target) - (let ((source (string-trim source #\/))) - (mkdir-p (dirname source)) - (symlink (string-append path "/" target) - source)))) - symlinks) - - (and (zero? (apply system* "tar" "-cf" "layer.tar" - (append %tar-determinism-options - items - (map symlink-source symlinks)))) - (for-each delete-file-recursively - (map (compose topmost-component symlink-source) - symlinks))))) - - (with-output-to-file "config.json" - (lambda () - (scm->json (config (string-append id "/layer.tar") - time arch)))) - (with-output-to-file "manifest.json" - (lambda () - (scm->json (manifest path id)))) - (with-output-to-file "repositories" - (lambda () - (scm->json (repositories path id))))) - - (and (zero? (apply system* "tar" "-C" directory "-cf" image - `(,@%tar-determinism-options - ,@(if compressor - (list "-I" (string-join compressor)) - '()) - "."))) - (begin (delete-file-recursively directory) #t))))) + (with-directory-excursion directory + (mkdir id) + (with-directory-excursion id + (with-output-to-file "VERSION" + (lambda () (display schema-version))) + (with-output-to-file "json" + (lambda () (scm->json (image-description id time)))) + + ;; Create SYMLINKS. + (for-each (match-lambda + ((source '-> target) + (let ((source (string-trim source #\/))) + (mkdir-p (dirname source)) + (symlink (string-append prefix "/" target) + source)))) + symlinks) + + (apply invoke "tar" "-cf" "layer.tar" + `(,@transformation-options + ,@%tar-determinism-options + ,@paths + ,@(map symlink-source symlinks))) + ;; It is possible for "/" to show up in the archive, especially when + ;; applying transformations. For example, the transformation + ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform + ;; the path "/a" into "/". The presence of "/" in the archive is + ;; probably benign, but it is definitely safe to remove it, so let's + ;; do that. This fails when "/" is not in the archive, so use system* + ;; instead of invoke to avoid an exception in that case. + (system* "tar" "--delete" "/" "-f" "layer.tar") + (for-each delete-file-recursively + (map (compose topmost-component symlink-source) + symlinks))) + + (with-output-to-file "config.json" + (lambda () + (scm->json (config (string-append id "/layer.tar") + time arch)))) + (with-output-to-file "manifest.json" + (lambda () + (scm->json (manifest prefix id)))) + (with-output-to-file "repositories" + (lambda () + (scm->json (repositories prefix id))))) + + (apply invoke "tar" "-cf" image "-C" directory + `(,@%tar-determinism-options + ,@(if compressor + (list "-I" (string-join compressor)) + '()) + ".")) + (delete-file-recursively directory))) diff --git a/guix/gexp.scm b/guix/gexp.scm index 8dea022e04..b47965d9eb 100644 --- a/guix/gexp.scm +++ b/guix/gexp.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, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. @@ -60,6 +60,7 @@ program-file-name program-file-gexp program-file-guile + program-file-module-path scheme-file scheme-file? @@ -380,25 +381,28 @@ This is the declarative counterpart of 'gexp->derivation'." (apply gexp->derivation name gexp options))))) (define-record-type <program-file> - (%program-file name gexp guile) + (%program-file name gexp guile path) program-file? (name program-file-name) ;string (gexp program-file-gexp) ;gexp - (guile program-file-guile)) ;package + (guile program-file-guile) ;package + (path program-file-module-path)) ;list of strings -(define* (program-file name gexp #:key (guile #f)) +(define* (program-file name gexp #:key (guile #f) (module-path %load-path)) "Return an object representing the executable store item NAME that runs -GEXP. GUILE is the Guile package used to execute that script. +GEXP. GUILE is the Guile package used to execute that script. Imported +modules of GEXP are looked up in MODULE-PATH. This is the declarative counterpart of 'gexp->script'." - (%program-file name gexp guile)) + (%program-file name gexp guile module-path)) (define-gexp-compiler (program-file-compiler (file <program-file>) system target) ;; Compile FILE by returning a derivation that builds the script. (match file - (($ <program-file> name gexp guile) + (($ <program-file> name gexp guile module-path) (gexp->script name gexp + #:module-path module-path #:guile (or guile (default-guile)))))) (define-record-type <scheme-file> @@ -1116,11 +1120,14 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2)) -(define (load-path-expression modules) +(define* (load-path-expression modules #:optional (path %load-path)) "Return as a monadic value a gexp that sets '%load-path' and -'%load-compiled-path' to point to MODULES, a list of module names." - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules))) +'%load-compiled-path' to point to MODULES, a list of module names. MODULES +are searched for in PATH." + (mlet %store-monad ((modules (imported-modules modules + #:module-path path)) + (compiled (compiled-modules modules + #:module-path path))) (return (gexp (eval-when (expand load eval) (set! %load-path (cons (ungexp modules) %load-path)) @@ -1129,11 +1136,13 @@ they can refer to each other." %load-compiled-path))))))) (define* (gexp->script name exp - #:key (guile (default-guile))) + #:key (guile (default-guile)) + (module-path %load-path)) "Return an executable script NAME that runs EXP using GUILE, with EXP's -imported modules in its search path." +imported modules in its search path. Look up EXP's modules in MODULE-PATH." (mlet %store-monad ((set-load-path - (load-path-expression (gexp-modules exp)))) + (load-path-expression (gexp-modules exp) + module-path))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1148,12 +1157,16 @@ imported modules in its search path." (write '(ungexp set-load-path) port) (write '(ungexp exp) port) - (chmod port #o555))))))) + (chmod port #o555)))) + #:module-path module-path))) -(define* (gexp->file name exp #:key (set-load-path? #t)) +(define* (gexp->file name exp #:key + (set-load-path? #t) + (module-path %load-path)) "Return a derivation that builds a file NAME containing EXP. When SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' -and '%load-compiled-path' to honor EXP's imported modules." +and '%load-compiled-path' to honor EXP's imported modules. Lookup EXP's +modules in MODULE-PATH." (match (if set-load-path? (gexp-modules exp) '()) (() ;zero modules (gexp->derivation name @@ -1164,13 +1177,15 @@ and '%load-compiled-path' to honor EXP's imported modules." #:local-build? #t #:substitutable? #f)) ((modules ...) - (mlet %store-monad ((set-load-path (load-path-expression modules))) + (mlet %store-monad ((set-load-path (load-path-expression modules + module-path))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) (lambda (port) (write '(ungexp set-load-path) port) (write '(ungexp exp) port)))) + #:module-path module-path #:local-build? #t #:substitutable? #f))))) diff --git a/guix/git.scm b/guix/git.scm index d31c35f64f..103749d0e2 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -147,6 +147,13 @@ Git repositories are kept in the cache directory specified by (when cache-exists? (remote-fetch (remote-lookup repository "origin"))) (switch-to-ref repository ref) + + ;; Reclaim file descriptors and memory mappings associated with + ;; REPOSITORY as soon as possible. + (when (module-defined? (resolve-interface '(git repository)) + 'repository-close!) + (repository-close! repository)) + (copy-to-store store cache-dir #:url url #:repository repository)))) diff --git a/guix/modules.scm b/guix/modules.scm index 6c602eda48..bf656bb241 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +29,7 @@ file-name->module-name module-name->file-name + source-module-dependencies source-module-closure live-module-closure guix-module-name?)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 57f2d82c5c..401087e830 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -69,13 +69,21 @@ found. Return #f if no build log was found." (define (valid-url? url) ;; Probe URL and return #t if it is accessible. - (catch 'getaddrinfo-error + (catch #t (lambda () (guard (c ((http-get-error? c) #f)) (close-port (http-fetch url #:buffered? #f)) #t)) - (lambda _ - #f))) + (match-lambda* + (('getaddrinfo-error . _) + #f) + (('tls-certificate-error args ...) + (report-error (G_ "cannot access build log at '~a':~%") url) + (print-exception (current-error-port) #f + 'tls-certificate-error args) + (exit 1)) + ((key . args) + (apply throw key args))))) (define (find-url file) (let ((base (basename file))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 4f88c513c0..f8a9702b30 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -332,7 +332,7 @@ packages." (let ((module (make-user-module '()))) (packages->outputs (load* file module) mode))) (('manifest . file) - (let ((module (make-user-module '()))) + (let ((module (make-user-module '((guix profiles) (gnu))))) (manifest->outputs (load* file module)))) (_ '(#f))) opts))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index a31d2236b0..e4ed7227ff 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,6 +61,8 @@ Invoke the garbage collector.\n")) -R, --requisites list the requisites of PATHS")) (display (G_ " --referrers list the referrers of PATHS")) + (display (G_ " + --derivers list the derivers of PATHS")) (newline) (display (G_ " --verify[=OPTS] verify the integrity of the store; OPTS is a @@ -153,6 +155,10 @@ Invoke the garbage collector.\n")) (lambda (opt name arg result) (alist-cons 'action 'list-referrers (alist-delete 'action result)))) + (option '("derivers") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-derivers + (alist-delete 'action result)))) (option '("list-failures") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-failures @@ -241,6 +247,8 @@ Invoke the garbage collector.\n")) (requisites store (list item))))) ((list-referrers) (list-relatives referrers)) + ((list-derivers) + (list-relatives valid-derivers)) ((optimize) (assert-no-extra-arguments) (optimize-store store)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 78f09f181b..346ca4ea88 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,9 +27,11 @@ #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix memoization) + #:use-module (guix modules) #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) + #:use-module ((guix utils) #:select (location-file)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -44,6 +46,7 @@ %derivation-node-type %reference-node-type %referrer-node-type + %module-node-type %node-types guix-graph)) @@ -332,6 +335,36 @@ substitutes." ;;; +;;; Scheme modules. +;;; + +(define (module-from-package package) + (file-name->module-name (location-file (package-location package)))) + +(define (source-module-dependencies* module) + "Like 'source-module-dependencies' but filter out modules that are not +package modules, while attempting to retain user package modules." + (remove (match-lambda + (('guix _ ...) #t) + (('system _ ...) #t) + (('language _ ...) #t) + (('ice-9 _ ...) #t) + (('srfi _ ...) #t) + (_ #f)) + (source-module-dependencies module))) + +(define %module-node-type + ;; Show the graph of package modules. + (node-type + (name "module") + (description "the graph of package modules") + (convert (lift1 (compose list module-from-package) %store-monad)) + (identifier (lift1 identity %store-monad)) + (label object->string) + (edges (lift1 source-module-dependencies* %store-monad)))) + + +;;; ;;; List of node types. ;;; @@ -344,7 +377,8 @@ substitutes." %bag-emerged-node-type %derivation-node-type %reference-node-type - %referrer-node-type)) + %referrer-node-type + %module-node-type)) (define (lookup-node-type name) "Return the node type called NAME. Raise an error if it is not found." diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 59dd117edb..488638adc5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> +;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,9 @@ #:use-module (guix derivations) #:use-module (guix scripts build) #:use-module (gnu packages) + #:use-module (gnu packages bootstrap) #:use-module (gnu packages compression) + #:use-module (gnu packages guile) #:autoload (gnu packages base) (tar) #:autoload (gnu packages package-management) (guix) #:autoload (gnu packages gnupg) (libgcrypt) @@ -67,6 +70,11 @@ #~(#+(file-append bzip2 "/bin/bzip2") "-9")) (compressor "none" "" #f))) +;; This one is only for use in this module, so don't put it in %compressors. +(define bootstrap-xz + (compressor "bootstrap-xz" ".xz" + #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e -T0"))) + (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be found." @@ -230,6 +238,7 @@ the image." (define build (with-imported-modules `(,@(source-module-closure '((guix docker)) #:select? not-config?) + (guix build store-copy) ((guix config) => ,config)) #~(begin ;; Guile-JSON is required by (guix docker). @@ -237,13 +246,15 @@ the image." (string-append #+json "/share/guile/site/" (effective-version))) - (use-modules (guix docker) (srfi srfi-19)) + (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) (setenv "PATH" (string-append #$tar "/bin")) - (build-docker-image #$output #$profile + (build-docker-image #$output + (call-with-input-file "profile" + read-reference-graph) + #$profile #:system (or #$target (utsname:machine (uname))) - #:closure "profile" #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1))))) @@ -325,6 +336,9 @@ the image." (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) (append %transformation-options %standard-build-options))) @@ -352,6 +366,8 @@ Create a bundle of PACKAGE.\n")) -m, --manifest=FILE create a pack with the manifest from FILE")) (display (G_ " --localstatedir include /var/guix in the resulting pack")) + (display (G_ " + --bootstrap use the bootstrap binaries to build the pack")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -393,28 +409,43 @@ Create a bundle of PACKAGE.\n")) (else (packages->manifest packages))))) (with-error-handling - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (manifest (manifest-from-args opts)) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (compressor (assoc-ref opts 'compressor)) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format") - format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) - (with-store store + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (manifest (manifest-from-args opts)) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (tar (if bootstrap? + %bootstrap-coreutils&co + tar)) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format") + format)))) + (localstatedir? (assoc-ref opts 'localstatedir?))) + (with-store store + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) #:target target)) (drv (build-image name profile #:target @@ -424,7 +455,9 @@ Create a bundle of PACKAGE.\n")) #:symlinks symlinks #:localstatedir? - localstatedir?))) + localstatedir? + #:tar + tar))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f0c4a2ba1b..b50cabcd1a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> -;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -701,7 +701,9 @@ checking this by themselves in their 'check' procedure." ("iso9660" "image.iso") (_ "disk-image")) #:disk-image-size image-size - #:file-system-type file-system-type)))) + #:file-system-type file-system-type)) + ((docker-image) + (system-docker-image os #:register-closures? #t)))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." @@ -905,6 +907,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ disk-image build a disk image, suitable for a USB stick\n")) (display (G_ "\ + docker-image build a Docker image\n")) + (display (G_ "\ init initialize a root file system to run GNU\n")) (display (G_ "\ extension-graph emit the service extension graph in Dot format\n")) @@ -1142,7 +1146,7 @@ argument list and OPTS is the option alist." (case action ((build container vm vm-image disk-image reconfigure init extension-graph shepherd-graph list-generations roll-back - switch-generation search) + switch-generation search docker-image) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) @@ -1171,7 +1175,7 @@ argument list and OPTS is the option alist." (exit 1)) (case action - ((build container vm vm-image disk-image reconfigure) + ((build container vm vm-image disk-image docker-image reconfigure) (unless (or (= count 1) (and expr (= count 0))) (fail))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 2e782e36ce..5c934abaef 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -29,11 +29,14 @@ #:use-module (guix grafts) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (guix scripts substitute) + #:use-module (guix http-client) + #:use-module (guix ci) #:use-module (gnu packages) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) @@ -100,6 +103,57 @@ values." (define-syntax-rule (let/time ((time result exp)) body ...) (call-with-time (lambda () exp) (lambda (time result) body ...))) +(define (histogram field proc seed lst) + "Return an alist giving a histogram of all the values of FIELD for elements +of LST. FIELD must be a one element procedure that returns a field's value. +For each FIELD value, call PROC with the previous field-specific result. +Example: + + (histogram car (lambda (x n) (+ 1 n)) 0 '((a . x)(b . y)(a . z))) + => ((a . 2) (b . 1)) + +meaning that we have two a's and one b." + (let loop ((lst lst) + (result '())) + (match lst + (() + result) + ((head . tail) + (let ((value (field head))) + (loop tail + (match (assoc-ref result value) + (#f + `((,value . ,(proc head seed)) ,@result)) + (previous + `((,value . ,(proc head previous)) + ,@(alist-delete value result)))))))))) + +(define (throughput lst timestamp) + "Return the throughput, in items per second, given the elements of LST, +calling TIMESTAMP to get the \"timestamp\" of each item." + (let ((oldest (reduce min +inf.0 (map build-timestamp lst))) + (now (time-second (current-time time-utc)))) + (/ (length lst) (- now oldest) 1.))) + +(define (queued-subset queue items) + "Return the subset of ITEMS, a list of store file names, that appears in +QUEUE, a list of builds. Return #f if elements in QUEUE lack information +about the derivations queued, as is the case with Hydra." + (define queued + (append-map (lambda (build) + (match (false-if-exception + (read-derivation-from-file (build-derivation build))) + (#f + '()) + (drv + (match (derivation->output-paths drv) + (((names . items) ...) items))))) + queue)) + + (if (any (negate build-derivation) queue) + #f ;no derivation information + (lset-intersection string=? queued items))) + (define (report-server-coverage server items) "Report the subset of ITEMS available as substitutes on SERVER." (define MiB (* (expt 2 20) 1.)) @@ -111,6 +165,8 @@ values." (format #t "~a~%" server) (let ((obtained (length narinfos)) (requested (length items)) + (missing (lset-difference string=? + items (map narinfo-path narinfos))) (sizes (filter-map narinfo-file-size narinfos)) (time (+ (time-second time) (/ (time-nanosecond time) 1e9)))) @@ -131,7 +187,56 @@ values." (format #t (G_ " ~,3h seconds per request (~,1h seconds in total)~%") (/ time requested 1.) time) (format #t (G_ " ~,1h requests per second~%") - (/ requested time 1.))))) + (/ requested time 1.)) + + (guard (c ((http-get-error? c) + (if (= 404 (http-get-error-code c)) + (format (current-error-port) + (G_ " (continuous integration information \ +unavailable)~%")) + (format (current-error-port) + (G_ " '~a' returned ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c))))) + (let* ((max %query-limit) + (queue (queued-builds server max)) + (len (length queue)) + (histo (histogram build-system + (lambda (build count) + (+ 1 count)) + 0 queue))) + (newline) + (unless (null? missing) + (let ((missing (length missing))) + (match (queued-subset queue missing) + (#f #f) + ((= length queued) + (format #t (G_ " ~,1f% (~h out of ~h) of the missing items \ +are queued~%") + (* 100. (/ queued missing)) + queued missing))))) + + (if (>= len max) + (format #t (G_ " at least ~h queued builds~%") len) + (format #t (G_ " ~h queued builds~%") len)) + (for-each (match-lambda + ((system . count) + (format #t (G_ " ~a: ~a (~0,1f%)~%") + system count (* 100. (/ count len))))) + histo)) + + (let* ((latest (latest-builds server)) + (builds/sec (throughput latest build-timestamp))) + (format #t (G_ " build rate: ~1,2f builds per hour~%") + (* builds/sec 3600.)) + (for-each (match-lambda + ((system . builds) + (format #t (G_ " ~a: ~,2f builds per hour~%") + system + (* (throughput builds build-timestamp) + 3600.)))) + (histogram build-system cons '() latest))))))) ;;; |