diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/asdf.scm | 3 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 12 | ||||
| -rw-r--r-- | guix/diagnostics.scm | 38 | ||||
| -rw-r--r-- | guix/docker.scm | 9 | ||||
| -rw-r--r-- | guix/gnupg.scm | 31 | ||||
| -rw-r--r-- | guix/import/opam.scm | 5 | ||||
| -rw-r--r-- | guix/import/texlive.scm | 264 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/home.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/import/texlive.scm | 16 | ||||
| -rw-r--r-- | guix/svn-download.scm | 31 |
11 files changed, 287 insertions, 134 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f043e6a7a2..a0f4634db0 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -151,7 +151,8 @@ set up using CL source package conventions." name)) (define (has-from-build-system? pkg) - (eq? from-build-system (package-build-system pkg))) + (and (package? pkg) + (eq? from-build-system (package-build-system pkg)))) (define (find-input-package pkg) (let* ((name (package-name pkg)) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 15b2ea6ff3..45f95c509d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -71,6 +71,11 @@ mounts mount-points + SWAP_FLAG_PREFER + SWAP_FLAG_PRIO_MASK + SWAP_FLAG_PRIO_SHIFT + SWAP_FLAG_DISCARD + swapon swapoff @@ -687,6 +692,13 @@ current process." "Return the mounts points for currently mounted file systems." (map mount-point (mounts))) +;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h + +(define SWAP_FLAG_PREFER #x8000) ;; Set if swap priority is specified. +(define SWAP_FLAG_PRIO_MASK #x7fff) +(define SWAP_FLAG_PRIO_SHIFT 0) +(define SWAP_FLAG_DISCARD #x10000) ;; Discard swap cluster after use. + (define swapon (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 6a792febd4..337a73c1a2 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -54,7 +54,9 @@ condition-fix-hint guix-warning-port - program-name)) + program-name + + define-with-syntax-properties)) ;;; Commentary: ;;; @@ -331,3 +333,37 @@ number of arguments in ARGS matches the escapes in FORMAT." (define program-name ;; Name of the command-line program currently executing, or #f. (make-parameter #f)) + + +(define-syntax define-with-syntax-properties + (lambda (x) + "Define BINDING to be a syntax form replacing each VALUE-IDENTIFIER and +SYNTAX-PROPERTIES-IDENTIFIER in body by the syntax and syntax-properties, +respectively, of each ensuing syntax object." + (syntax-case x () + ((_ (binding (value-identifier syntax-properties-identifier) + ...) + body ...) + (and (and-map identifier? #'(value-identifier ...)) + (and-map identifier? #'(syntax-properties-identifier ...))) + #'(define-syntax binding + (lambda (y) + (with-ellipsis ::: + (syntax-case y () + ((_ value-identifier ...) + (with-syntax ((syntax-properties-identifier + #`'#,(datum->syntax y + (syntax-source + #'value-identifier))) + ...) + #'(begin body ...))) + (_ + (syntax-violation #f (format #f + "Expected (~a~{ ~a~})" + 'binding + '(value-identifier ...)) + y))))))) + (_ + (syntax-violation #f "Expected a definition of the form \ +(define-with-syntax-properties (binding (value syntax-properties) \ +...) body ...)" x))))) diff --git a/guix/docker.scm b/guix/docker.scm index a6f73d423c..5e6460f43f 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -214,10 +214,11 @@ SRFI-19 time-utc object, as the creation time in metadata." (else (error "unsupported system" system))))))) - (cond* ("x86_64" "amd64") - ("i686" "386") - ("arm" "arm") - ("mips64" "mips64le"))))) + (cond* ("x86_64" "amd64") + ("i686" "386") + ("arm" "arm") + ("aarch64" "arm64") + ("mips64" "mips64le"))))) ;; Make sure we start with a fresh, empty working directory. (mkdir directory) (with-directory-excursion directory diff --git a/guix/gnupg.scm b/guix/gnupg.scm index 5fae24b325..088bebc0de 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,9 +57,9 @@ "/gpg/trustedkeys.kbx"))) (define %openpgp-key-server - ;; The default key server. Note that keys.gnupg.net appears to be - ;; unreliable. - (make-parameter "pool.sks-keyservers.net")) + ;; The default key server. It defaults to #f, which causes GnuPG to use the + ;; one it is configured with. + (make-parameter #f)) ;; Regexps for status lines. See file `doc/DETAILS' in GnuPG. @@ -182,22 +183,26 @@ missing key or its key id if the fingerprint is unavailable." (_ #f))) status)) -(define* (gnupg-receive-keys fingerprint/key-id server - #:optional (keyring (current-keyring))) - "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to -KEYRING." +(define* (gnupg-receive-keys fingerprint/key-id + #:key server (keyring (current-keyring))) + "Download FINGERPRINT/KEY-ID from SERVER if specified, otherwise from +GnuPG's default/configured one. The key is added to KEYRING." (unless (file-exists? keyring) (mkdir-p (dirname keyring)) - (call-with-output-file keyring (const #t))) ;create an empty keybox + (call-with-output-file keyring (const #t))) ;create an empty keybox - (zero? (system* (%gpg-command) "--keyserver" server - "--no-default-keyring" "--keyring" keyring - "--recv-keys" fingerprint/key-id))) + (zero? (apply system* + `(,(%gpg-command) + ,@(if server + (list "--keyserver" server) + '()) + "--no-default-keyring" "--keyring" ,keyring + "--recv-keys" ,fingerprint/key-id)))) (define* (gnupg-verify* sig file #:key (key-download 'interactive) - (server (%openpgp-key-server)) + server (keyring (current-keyring))) "Like `gnupg-verify', but try downloading the public key if it's missing. Return two values: 'valid-signature and a fingerprint/name pair upon success, @@ -215,7 +220,7 @@ fingerprint/user name pair on success and #f otherwise." (let ((missing (gnupg-status-missing-key? status))) (define (download-and-try-again) ;; Download the missing key and try again. - (if (gnupg-receive-keys missing server keyring) + (if (gnupg-receive-keys missing #:server server #:keyring keyring) (match (gnupg-status-good-signature? (gnupg-verify sig file keyring)) (#f diff --git a/guix/import/opam.scm b/guix/import/opam.scm index f8402ff5ba..d9fdf4527a 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -231,7 +231,8 @@ path to the repository." (('list-pat . stuff) stuff) (('string-pat stuff) stuff) (('multiline-string stuff) stuff) - (('dict records ...) records)) + (('dict records ...) records) + (_ #f)) acc)))) #f file)) @@ -317,7 +318,7 @@ path to the repository." (_ others))) #f (filter-map get-opam-repository repositories-specs)) - (leave (G_ "package '~a' not found~%") name))) + (warning (G_ "opam: package '~a' not found~%") name))) (define* (opam->guix-package name #:key (repo 'opam) version) "Import OPAM package NAME from REPOSITORY (a directory name) or, if diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 18d8b95ee0..bdef9f58b0 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -19,18 +19,16 @@ (define-module (guix import texlive) #:use-module (ice-9 match) - #:use-module (sxml simple) - #:use-module (sxml xpath) - #:use-module (srfi srfi-11) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (web uri) - #:use-module (guix diagnostics) - #:use-module (guix i18n) - #:use-module (guix http-client) #:use-module (gcrypt hash) + #:use-module (guix derivations) #:use-module (guix memoization) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix base32) #:use-module (guix serialization) @@ -39,24 +37,15 @@ #:use-module (guix utils) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (gnu packages) #:use-module (guix build-system texlive) #:export (texlive->guix-package - - fetch-sxml - sxml->package)) + texlive-recursive-import)) ;;; Commentary: ;;; -;;; Generate a package declaration template for the latest version of a -;;; package on CTAN, using the XML output produced by the XML API to the CTAN -;;; database at http://www.ctan.org/xml/1.2/ -;;; -;;; Instead of taking the packages from CTAN, however, we fetch the sources -;;; from the SVN repository of the Texlive project. We do this because CTAN -;;; only keeps a single version of each package whereas we can access any -;;; version via SVN. Unfortunately, this means that the importer is really -;;; just a Texlive importer, not a generic CTAN importer. +;;; Generate a package declaration template for corresponding package in the +;;; Tex Live Package Database (tlpdb). We fetch all sources from different +;;; locations in the SVN repository of the Texlive project. ;;; ;;; Code: @@ -79,6 +68,8 @@ ("bsd4" 'bsd-4) ("opl" 'opl1.0+) ("ofl" 'silofl1.1) + + ("lpplgpl" `(list lppl gpl1+)) ("lppl" 'lppl) ("lppl1" 'lppl1.0+) ; usually means "or later" ("lppl1.2" 'lppl1.2+) ; usually means "or later" @@ -107,91 +98,170 @@ ("cc-by-nc-nd-4" 'non-free) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) - (_ #f))) - -(define (fetch-sxml name) - "Return an sxml representation of the package information contained in the -XML description of the CTAN package or #f in case of failure." - ;; This API always returns the latest release of the module. - (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (xml->sxml (http-fetch url) - #:trim-whitespace? #t)))) - -(define (guix-name component name) + (x `(error unknown-license ,x)))) + +(define (guix-name name) "Return a Guix package name for a given Texlive package NAME." - (string-append "texlive-" component "-" + (string-append "texlive-" (string-map (match-lambda (#\_ #\-) (#\. #\-) (chr (char-downcase chr))) name))) -(define* (sxml->package sxml #:optional (component "latex")) - "Return the `package' s-expression for a Texlive package from the SXML -expression describing it." - (define (sxml-value path) - (match ((sxpath path) sxml) - (() #f) - ((val) val))) +(define (tlpdb-file) + (define texlive-bin + ;; Resolve this variable lazily so that (gnu packages ...) does not end up + ;; in the closure of this module. + (module-ref (resolve-interface '(gnu packages tex)) + 'texlive-bin)) + (with-store store - (let* ((id (sxml-value '(entry @ id *text*))) - (synopsis (sxml-value '(entry caption *text*))) - (version (or (sxml-value '(entry version @ number *text*)) - (sxml-value '(entry version @ date *text*)))) - (license (match ((sxpath '(entry license @ type *text*)) sxml) - ((license) (string->license license)) - ((lst ...) (map string->license lst)))) - (home-page (string-append "http://www.ctan.org/pkg/" id)) - (ref (texlive-ref component id)) - (checkout (download-svn-to-store store ref))) - (unless checkout - (warning (G_ "Could not determine source location. \ -Please manually specify the source field.~%"))) - `(package - (name ,(guix-name component id)) - (version ,version) - (source ,(if checkout - `(origin - (method svn-fetch) - (uri (texlive-ref ,component ,id)) - (sha256 - (base32 - ,(bytevector->nix-base32-string - (let-values (((port get-hash) (open-sha256-port))) - (write-file checkout port) - (force-output port) - (get-hash)))))) - #f)) - (build-system texlive-build-system) - (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,(string-trim-both - (string-join - (map string-trim-both - (string-split - (beautify-description - (sxml->string (or (sxml-value '(entry description)) - '()))) - #\newline))))) - (license ,(match license - ((lst ...) `(list ,@lst)) - (license license))))))) + (run-with-store store + (mlet* %store-monad + ((drv (lower-object texlive-bin)) + (built (built-derivations (list drv)))) + (match (derivation->output-paths drv) + (((names . items) ...) + (return (string-append (first items) + "/share/tlpkg/texlive.tlpdb")))))))) + +(define tlpdb + (memoize + (lambda () + (let ((file (tlpdb-file)) + (fields + '((name . string) + (shortdesc . string) + (longdesc . string) + (catalogue-license . string) + (catalogue-ctan . string) + (srcfiles . list) + (runfiles . list) + (docfiles . list) + (depend . simple-list))) + (record + (lambda* (key value alist #:optional (type 'string)) + (let ((new + (or (and=> (assoc-ref alist key) + (lambda (existing) + (cond + ((eq? type 'string) + (string-append existing " " value)) + ((or (eq? type 'list) (eq? type 'simple-list)) + (cons value existing))))) + (cond + ((eq? type 'string) + value) + ((or (eq? type 'list) (eq? type 'simple-list)) + (list value)))))) + (acons key new (alist-delete key alist)))))) + (call-with-input-file file + (lambda (port) + (let loop ((all (list)) + (current (list)) + (last-property #false)) + (let ((line (read-line port))) + (cond + ((eof-object? line) all) + + ;; End of record. + ((string-null? line) + (loop (cons (cons (assoc-ref current 'name) current) + all) + (list) #false)) + + ;; Continuation of a list + ((and (zero? (string-index line #\space)) last-property) + ;; Erase optional second part of list values like + ;; "details=Readme" for files + (let ((plain-value (first + (string-split + (string-trim-both line) #\space)))) + (loop all (record last-property + plain-value + current + 'list) + last-property))) + (else + (or (and-let* ((space (string-index line #\space)) + (key (string->symbol (string-take line space))) + (value (string-drop line (1+ space))) + (field-type (assoc-ref fields key))) + ;; Erase second part of list keys like "size=29" + (cond + ((eq? field-type 'list) + (loop all current key)) + (else + (loop all (record key value current field-type) key)))) + (loop all current #false)))))))))))) + +(define (files->directories files) + (map (cut string-join <> "/" 'suffix) + (delete-duplicates (map (lambda (file) + (drop-right (string-split file #\/) 1)) + files) + equal?))) + +(define (tlpdb->package name package-database) + (and-let* ((data (assoc-ref package-database name)) + (dirs (files->directories + (map (lambda (dir) + (string-drop dir (string-length "texmf-dist/"))) + (append (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'srcfiles) (list)))))) + (name (guix-name name)) + (version (number->string %texlive-revision)) + (ref (svn-multi-reference + (url (string-append "svn://www.tug.org/texlive/tags/" + %texlive-tag "/Master/texmf-dist")) + (locations dirs) + (revision %texlive-revision))) + (source (with-store store + (download-multi-svn-to-store + store ref (string-append name "-svn-multi-checkout"))))) + (values + `(package + (inherit (simple-texlive-package + ,name + (list ,@dirs) + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file source port) + (force-output port) + (get-hash)))) + ,@(if (assoc-ref data 'srcfiles) '() '(#:trivial? #true)))) + ,@(or (and=> (assoc-ref data 'depend) + (lambda (inputs) + `((propagated-inputs + ,(map (lambda (tex-name) + (let ((name (guix-name tex-name))) + (list name (list 'unquote (string->symbol name))))) + inputs))))) + '()) + ,@(or (and=> (assoc-ref data 'catalogue-ctan) + (lambda (url) + `((home-page ,(string-append "https://ctan.org" url))))) + '((home-page "https://www.tug.org/texlive/"))) + (synopsis ,(assoc-ref data 'shortdesc)) + (description ,(beautify-description + (assoc-ref data 'longdesc))) + (license ,(string->license + (assoc-ref data 'catalogue-license)))) + (or (assoc-ref data 'depend) (list))))) (define texlive->guix-package (memoize - (lambda* (package-name #:optional (component "latex")) - "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' + (lambda* (name #:key repo version (package-database tlpdb)) + "Find the metadata for NAME in the tlpdb and return the `package' s-expression corresponding to that package, or #f on failure." - (and=> (fetch-sxml package-name) - (cut sxml->package <> component))))) + (tlpdb->package name (package-database))))) + +(define (texlive-recursive-import name) + (recursive-import name + #:repo->guix-package texlive->guix-package + #:guix-name guix-name)) -;;; ctan.scm ends here +;;; texlive.scm ends here diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 439fae0b52..8943e87099 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -542,7 +542,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " --list-types list the available graph types")) (display (G_ " - --max-depth=DEPTH limit to nodes within distance DEPTH")) + -M, --max-depth=DEPTH limit to nodes within distance DEPTH")) (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 3f48b98ed4..afc7d8b39c 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -274,7 +274,15 @@ argument list and OPTS is the option alist." (_ (leave (G_ "wrong number of arguments~%")))))) (unless (file-exists? destination) (mkdir-p destination)) - (import-manifest manifest destination (current-output-port)))) + (call-with-output-file + (string-append destination "/home-configuration.scm") + (cut import-manifest manifest destination <>)) + (info (G_ "'~a' populated with all the Home configuration files~%") + destination) + (display-hint (format #f (G_ "\ +Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively +deploy the home environment described by these files.\n") + destination)))) ((describe) (match (generation-number %guix-home) (0 diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm index 6f0818e274..4aeaa79eef 100644 --- a/guix/scripts/import/texlive.scm +++ b/guix/scripts/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. @@ -43,8 +43,6 @@ (display (G_ "Usage: guix import texlive PACKAGE-NAME Import and convert the Texlive package for PACKAGE-NAME.\n")) (display (G_ " - -a, --archive=ARCHIVE specify the archive repository")) - (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -60,10 +58,6 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import texlive"))) - (option '(#\a "archive") #t #f - (lambda (opt name arg result) - (alist-cons 'component arg - (alist-delete 'component result)))) %standard-import-options)) @@ -84,13 +78,11 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (let ((sexp (texlive->guix-package package-name - (or (assoc-ref opts 'component) - "latex")))) + ((name) + (let ((sexp (texlive->guix-package name))) (unless sexp (leave (G_ "failed to download description for package '~a'~%") - package-name)) + name)) sexp)) (() (leave (G_ "too few arguments~%"))) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 28ad49977b..55ce0d7351 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> -;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +26,9 @@ #:use-module (guix packages) #:use-module (guix utils) #:use-module ((guix build svn) #:prefix build:) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (svn-reference svn-reference? svn-reference-url @@ -41,7 +43,8 @@ svn-multi-reference-revision svn-multi-reference-locations svn-multi-reference-recursive? - svn-multi-fetch)) + svn-multi-fetch + download-multi-svn-to-store)) ;;; Commentary: ;;; @@ -166,4 +169,28 @@ reports to LOG." (add-to-store store name #t "sha256" (string-append temp "/svn"))))))) +(define* (download-multi-svn-to-store store ref + #:optional (name (basename (svn-multi-reference-url ref))) + #:key (log (current-error-port))) + "Download from REF, a <svn-multi-reference> object to STORE. Write progress +reports to LOG." + (call-with-temporary-directory + (lambda (temp) + (and (every (lambda (location) + (let ((dir (string-append temp "/" (dirname location)))) + (mkdir-p dir)) + (parameterize ((current-output-port log)) + (build:svn-fetch (string-append (svn-multi-reference-url ref) + "/" location) + (svn-multi-reference-revision ref) + (if (string-suffix? "/" location) + (string-append temp "/" location) + (string-append temp "/" (dirname location))) + #:recursive? + (svn-multi-reference-recursive? ref) + #:user-name (svn-multi-reference-user-name ref) + #:password (svn-multi-reference-password ref)))) + (svn-multi-reference-locations ref)) + (add-to-store store name #t "sha256" temp))))) + ;;; svn-download.scm ends here |