diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/texlive.scm | 2 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 78 | ||||
| -rw-r--r-- | guix/build/texlive-build-system.scm | 51 | ||||
| -rw-r--r-- | guix/discovery.scm | 14 | ||||
| -rw-r--r-- | guix/git.scm | 13 | ||||
| -rw-r--r-- | guix/packages.scm | 5 | ||||
| -rw-r--r-- | guix/profiles.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 23 | ||||
| -rw-r--r-- | guix/store.scm | 9 | ||||
| -rw-r--r-- | guix/ui.scm | 5 |
11 files changed, 154 insertions, 63 deletions
diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 0357c47a47..80882b144b 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -55,6 +55,7 @@ given Texlive COMPONENT." (define %texlive-build-system-modules ;; Build-side modules imported by default. `((guix build texlive-build-system) + (guix build union) ,@%gnu-build-system-modules)) (define (default-texlive-bin) @@ -114,6 +115,7 @@ given Texlive COMPONENT." (substitutable? #t) (imported-modules %texlive-build-system-modules) (modules '((guix build texlive-build-system) + (guix build union) (guix build utils)))) "Build SOURCE with INPUTS." (define builder diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 9c082b4352..549612fa3c 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -21,6 +21,7 @@ (define-module (guix build syscalls) #:use-module (system foreign) + #:use-module (system base target) ;for cross-compilation support #:use-module (rnrs bytevectors) #:autoload (ice-9 binary-ports) (get-bytevector-n) #:use-module (srfi srfi-1) @@ -824,28 +825,75 @@ system to PUT-OLD." ;;; Opendir & co. ;;; -(define-c-struct %struct-dirent-header - sizeof-dirent-header +(define (file-type->symbol type) + ;; Convert TYPE to symbols like 'stat:type' does. + (cond ((= type DT_REG) 'regular) + ((= type DT_LNK) 'symlink) + ((= type DT_DIR) 'directory) + ((= type DT_FIFO) 'fifo) + ((= type DT_CHR) 'char-special) + ((= type DT_BLK) 'block-special) + ((= type DT_SOCK) 'socket) + (else 'unknown))) + +;; 'struct dirent64' for GNU/Linux. +(define-c-struct %struct-dirent-header/linux + sizeof-dirent-header/linux (lambda (inode offset length type name) - ;; Convert TYPE to symbols like 'stat:type' does. - (let ((type (cond ((= type DT_REG) 'regular) - ((= type DT_LNK) 'symlink) - ((= type DT_DIR) 'directory) - ((= type DT_FIFO) 'fifo) - ((= type DT_CHR) 'char-special) - ((= type DT_BLK) 'block-special) - ((= type DT_SOCK) 'socket) - (else 'unknown)))) - `((type . ,type) - (inode . ,inode)))) - read-dirent-header - write-dirent-header! + `((type . ,(file-type->symbol type)) + (inode . ,inode))) + read-dirent-header/linux + write-dirent-header!/linux (inode int64) (offset int64) (length unsigned-short) (type uint8) (name uint8)) ;first byte of 'd_name' +;; 'struct dirent64' for GNU/Hurd. +(define-c-struct %struct-dirent-header/hurd + sizeof-dirent-header/hurd + (lambda (inode length type name-length name) + `((type . ,(file-type->symbol type)) + (inode . ,inode))) + read-dirent-header/hurd + write-dirent-header!/hurd + (inode int64) + (length unsigned-short) + (type uint8) + (namelen uint8) + (name uint8)) + +(define-syntax define-generic-identifier + (syntax-rules (gnu/linux gnu/hurd =>) + "Define a generic identifier that adjust to the current GNU variant." + ((_ id (gnu/linux => linux) (gnu/hurd => hurd)) + (define-syntax id + (lambda (s) + (syntax-case s () + ((_ args (... ...)) + (if (string-contains (or (target-type) %host-type) + "linux") + #'(linux args (... ...)) + #'(hurd args (... ...)))) + (_ + (if (string-contains (or (target-type) %host-type) + "linux") + #'linux + #'hurd)))))))) + +(define-generic-identifier read-dirent-header + (gnu/linux => read-dirent-header/linux) + (gnu/hurd => read-dirent-header/hurd)) + +(define-generic-identifier %struct-dirent-header + (gnu/linux => %struct-dirent-header/linux) + (gnu/hurd => %struct-dirent-header/hurd)) + +(define-generic-identifier sizeof-dirent-header + (gnu/linux => sizeof-dirent-header/linux) + (gnu/hurd => sizeof-dirent-header/hurd)) + ;; Constants for the 'type' field, from <dirent.h>. (define DT_UNKNOWN 0) (define DT_FIFO 1) diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index c1fd9fd9af..c0f262a5c0 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -19,7 +19,9 @@ (define-module (guix build texlive-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (guix build union) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -38,31 +40,34 @@ (string-append "&" format) file))) -(define* (build #:key inputs build-targets tex-format #:allow-other-keys) - ;; Find additional tex and sty files - (setenv "TEXINPUTS" - (string-append - (getcwd) ":" (getcwd) "/build:" - (string-join - (append-map (match-lambda - ((_ . dir) - (find-files dir - (lambda (_ stat) - (eq? 'directory (stat:type stat))) - #:directories? #t - #:stat stat))) - inputs) - ":"))) - (setenv "TEXFORMATS" - (string-append (assoc-ref inputs "texlive-latex-base") - "/share/texmf-dist/web2c/")) - (setenv "LUAINPUTS" - (string-append (assoc-ref inputs "texlive-latex-base") - "/share/texmf-dist/tex/latex/base/")) +(define* (configure #:key inputs #:allow-other-keys) + (let* ((out (string-append (getcwd) "/.texlive-union")) + (texmf.cnf (string-append out "/share/texmf-dist/web2c/texmf.cnf"))) + ;; Build a modifiable union of all inputs (but exclude bash) + (match inputs + (((names . directories) ...) + (union-build out directories + #:create-all-directories? #t + #:log-port (%make-void-port "w")))) + + ;; The configuration file "texmf.cnf" is provided by the + ;; "texlive-bin" package. We take it and override only the + ;; setting for TEXMFROOT and TEXMF. This file won't be consulted + ;; by default, though, so we still need to set TEXMFCNF. + (substitute* texmf.cnf + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " out "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")) + (setenv "TEXMFCNF" (dirname texmf.cnf)) + (setenv "TEXMF" (string-append out "/share/texmf-dist"))) (mkdir "build") + #t) + +(define* (build #:key inputs build-targets tex-format #:allow-other-keys) (every (cut compile-with-latex tex-format <>) (if build-targets build-targets - (find-files "." "\\.ins$")))) + (scandir "." (cut string-suffix? ".ins" <>))))) (define* (install #:key outputs tex-directory #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -76,7 +81,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases - (delete 'configure) + (replace 'configure configure) (replace 'build build) (delete 'check) (replace 'install install))) diff --git a/guix/discovery.scm b/guix/discovery.scm index 292df2bd9c..2741725b9d 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -60,11 +60,21 @@ DIRECTORY is not accessible." (case (entry-type absolute properties) ((directory) (append (scheme-files absolute) result)) - ((regular symlink) - ;; XXX: We don't recurse if we find a symlink. + ((regular) (if (string-suffix? ".scm" name) (cons absolute result) result)) + ((symlink) + (cond ((string-suffix? ".scm" name) + (cons absolute result)) + ((stat absolute #f) + => + (match-lambda + (#f result) + ((= stat:type 'directory) + (append (scheme-files absolute) + result)) + (_ result))))) (else result)))))) '() diff --git a/guix/git.scm b/guix/git.scm index 17a6784aef..406c817341 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -34,13 +34,12 @@ (make-parameter "/var/cache/guix/checkouts")) (define-syntax-rule (with-libgit2 thunk ...) - (dynamic-wind - (lambda () - (libgit2-init!)) - (lambda () - thunk ...) - (lambda () - (libgit2-shutdown)))) + (begin + ;; XXX: The right thing to do would be to call (libgit2-shutdown) here, + ;; but pointer finalizers used in guile-git may be called after shutdown, + ;; resulting in a segfault. Hence, let's skip shutdown call for now. + (libgit2-init!) + thunk ...)) (define* (url-cache-directory url #:optional (cache-directory diff --git a/guix/packages.scm b/guix/packages.scm index 75e53a2046..3528db442f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -269,8 +269,11 @@ name of its URI." ; inputs (native-search-paths package-native-search-paths (default '())) (search-paths package-search-paths (default '())) + + ;; The 'replacement' field is marked as "innate" because it never makes + ;; sense to inherit a replacement as is. See the 'package/inherit' macro. (replacement package-replacement ; package | #f - (default #f) (thunked)) + (default #f) (thunked) (innate)) (synopsis package-synopsis) ; one-line description (description package-description) ; one or two paragraphs diff --git a/guix/profiles.scm b/guix/profiles.scm index 056406e303..85c1722d62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -967,9 +967,13 @@ for both major versions of GTK+." "Return a derivation that builds the @file{mimeinfo.cache} database from desktop files. It's used to query what applications can handle a given MIME type." - (mlet %store-monad ((desktop-file-utils + (define desktop-file-utils ; lazy reference + (module-ref (resolve-interface '(gnu packages freedesktop)) + 'desktop-file-utils)) + + (mlet %store-monad ((glib (manifest-lookup-package - manifest "desktop-file-utils"))) + manifest "glib"))) (define build (with-imported-modules '((guix build utils) (guix build union)) @@ -990,8 +994,8 @@ MIME type." #:log-port (%make-void-port "w")) (exit (zero? (system* update-desktop-database destdir))))))) - ;; Don't run the hook when 'desktop-file-utils' is not referenced. - (if desktop-file-utils + ;; Don't run the hook when 'glib' is not referenced. + (if glib (gexp->derivation "xdg-desktop-database" build #:local-build? #t #:substitutable? #f) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 45f7cbbad5..32438b99d9 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -75,7 +75,8 @@ package names, build the underlying packages before sending them." (and (or (assoc-ref opts 'dry-run?) (build-derivations local drv)) - (let* ((session (open-ssh-session host #:user user #:port port)) + (let* ((session (open-ssh-session host #:user user + #:port (or port 22))) (sent (send-files local items (connect-to-remote-daemon session) #:recursive? #t))) @@ -88,7 +89,7 @@ package names, build the underlying packages before sending them." (let*-values (((user host port) (ssh-spec->user+host+port source)) ((session) - (open-ssh-session host #:user user #:port port)) + (open-ssh-session host #:user user #:port (or port 22))) ((remote) (connect-to-remote-daemon session))) (set-build-options-from-command-line local opts) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7e20b10dad..65dd92e8b7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -560,7 +560,8 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." ;;; (define* (system-derivation-for-action os action - #:key image-size full-boot? mappings) + #:key image-size file-system-type + full-boot? mappings) "Return as a monadic value the derivation for OS according to ACTION." (case action ((build init reconfigure) @@ -578,7 +579,8 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) - (system-disk-image os #:disk-image-size image-size)))) + (system-disk-image os #:disk-image-size image-size + #:file-system-type file-system-type)))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." @@ -610,13 +612,15 @@ and TARGET arguments." #:key install-bootloader? dry-run? derivations-only? use-substitutes? device target - image-size full-boot? + image-size file-system-type full-boot? (mappings '()) (gc-root #f)) "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install bootloader; DEVICE is the target devices for bootloader; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for the -'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action; +'vm-image' and 'disk-image' actions. +The root filesystem is created as a FILE-SYSTEM-TYPE filesystem. +FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without @@ -632,6 +636,7 @@ output when building a system derivation, such as a disk image." (mlet* %store-monad ((sys (system-derivation-for-action os action + #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) @@ -775,6 +780,10 @@ Some ACTIONS support additional ARGS.\n")) --on-error=STRATEGY apply STRATEGY when an error occurs while reading FILE")) (display (G_ " + --file-system-type=TYPE + for 'disk-image', produce a root file system of TYPE + (one of 'ext4', 'iso9660')")) + (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) @@ -812,6 +821,10 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'on-error (string->symbol arg) result))) + (option '(#\t "file-system-type") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-type arg + result))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -854,6 +867,7 @@ Some ACTIONS support additional ARGS.\n")) (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0) + (file-system-type . "ext4") (image-size . guess) (install-bootloader? . #t))) @@ -906,6 +920,7 @@ resulting from command-line parsing." #:derivations-only? (assoc-ref opts 'derivations-only?) #:use-substitutes? (assoc-ref opts 'substitutes?) + #:file-system-type (assoc-ref opts 'file-system-type) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) #:mappings (filter-map (match-lambda diff --git a/guix/store.scm b/guix/store.scm index d1a4c67ae8..a207d478e6 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1009,7 +1009,8 @@ error if there is no such root." length as ITEMS. Query substitute information for any item missing from the store at once. Raise a '&nix-protocol-error' exception if reference information for one of ITEMS is missing." - (let* ((local-refs (map (lambda (item) + (let* ((requested items) + (local-refs (map (lambda (item) (or (hash-ref %reference-cache item) (guard (c ((nix-protocol-error? c) #f)) (references store item)))) @@ -1023,7 +1024,9 @@ information for one of ITEMS is missing." ;; Query all the substitutes at once to minimize the cost of ;; launching 'guix substitute' and making HTTP requests. - (substs (substitutable-path-info store missing))) + (substs (if (null? missing) + '() + (substitutable-path-info store missing)))) (when (< (length substs) (length missing)) (raise (condition (&nix-protocol-error (message "cannot determine \ @@ -1038,7 +1041,7 @@ the list of references") (() (let ((result (reverse result))) (for-each (cut hash-set! %reference-cache <> <>) - items result) + requested result) result)) ((item items ...) (match local-refs diff --git a/guix/ui.scm b/guix/ui.scm index c141880316..4bad00e8cf 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -983,8 +983,9 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit." (if (> width 2) (- width 2) width)) (define (dependencies->recutils packages) - (let ((list (string-join (map package-full-name - (sort packages package<?)) " "))) + (let ((list (string-join (delete-duplicates + (map package-full-name + (sort packages package<?))) " "))) (string->recutils (fill-paragraph list width* (string-length "dependencies: "))))) |