diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/ocaml.scm | 27 | ||||
| -rw-r--r-- | guix/hg-download.scm | 38 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 21 | ||||
| -rw-r--r-- | guix/utils.scm | 6 |
5 files changed, 98 insertions, 5 deletions
diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index c5996bf0cf..5513216c25 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -29,6 +29,8 @@ #:export (%ocaml-build-system-modules package-with-ocaml4.07 strip-ocaml4.07-variant + package-with-ocaml4.09 + strip-ocaml4.09-variant default-findlib default-ocaml lower @@ -96,6 +98,18 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml4.07-dune))) +(define (default-ocaml4.09) + (let ((ocaml (resolve-interface '(gnu packages ocaml)))) + (module-ref ocaml 'ocaml-4.09))) + +(define (default-ocaml4.09-findlib) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml4.09-findlib))) + +(define (default-ocaml4.09-dune) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml4.09-dune))) + (define* (package-with-explicit-ocaml ocaml findlib dune old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package @@ -171,6 +185,19 @@ pre-defined variants." (inherit p) (properties (alist-delete 'ocaml4.07-variant (package-properties p))))) +(define package-with-ocaml4.09 + (package-with-explicit-ocaml (delay (default-ocaml4.09)) + (delay (default-ocaml4.09-findlib)) + (delay (default-ocaml4.09-dune)) + "ocaml-" "ocaml4.09-" + #:variant-property 'ocaml4.09-variant)) + +(define (strip-ocaml4.09-variant p) + "Remove the 'ocaml4.09-variant' property from P." + (package + (inherit p) + (properties (alist-delete 'ocaml4.09-variant (package-properties p))))) + (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 694105ceba..bd55946523 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -26,12 +26,14 @@ #:use-module (guix packages) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) #:export (hg-reference hg-reference? hg-reference-url hg-reference-changeset hg-reference-recursive? - + hg-predicate hg-fetch)) ;;; Commentary: @@ -93,4 +95,38 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:recursive? #t #:guile-for-build guile))) +(define (hg-file-list directory) + "Evaluates to a list of files contained in the repository at path + @var{directory}" + (let* ((port (open-input-pipe (format #f "hg files --repository ~s" directory))) + (files (let loop ((files '())) + (let ((line (read-line port))) + (cond + ((eof-object? line) files) + (else + (loop (cons line files)))))))) + (close-pipe port) + (map canonicalize-path files))) + +(define (should-select? path-list candidate) + "Returns #t in case that @var{candidate} is a file that is part of the given +@var{path-list}." + (let ((canon-candidate (canonicalize-path candidate))) + (let loop ((xs path-list)) + (cond + ((null? xs) + ;; Directories are not part of `hg files', but `local-file' will not + ;; recurse if we don't return #t for directories. + (equal? (array-ref (lstat candidate) 13) 'directory)) + ((string-contains candidate (car xs)) #t) + (else (loop (cdr xs))))))) + +(define (hg-predicate directory) + "This procedure evaluates to a predicate that reports back whether a given +@var{file} - @var{stat} combination is part of the files tracked by +Mercurial." + (let ((files (hg-file-list directory))) + (lambda (file stat) + (should-select? files file)))) + ;;; hg-download.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 02557ce454..c04baf9784 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -310,6 +311,16 @@ the input port." (leave (G_ "failed to read public key: ~a: ~a~%") (error-source err) (error-string err))))) + ;; Warn about potentially volatile ACLs, but continue: system reconfiguration + ;; might not be possible without (newly-authorized) substitutes. + (let ((stat (false-if-exception (lstat %acl-file)))) + (when (and stat (eq? 'symlink (stat:type (lstat %acl-file)))) + (warning (G_ "replacing symbolic link ~a with a regular file~%") + %acl-file) + (when (string-prefix? (%store-prefix) (readlink %acl-file)) + (display-hint (G_ "On Guix System, add public keys to the +@code{authorized-keys} field of your @code{operating-system} instead."))))) + (let ((key (read-key)) (acl (current-acl))) (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ad998156c2..db80e0be8f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -674,7 +674,8 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action os action #:key image-size image-type full-boot? container-shared-network? - mappings label) + mappings label + volatile-root?) "Return as a monadic value the derivation for OS according to ACTION." (mlet %store-monad ((target (current-target-system))) (case action @@ -706,7 +707,8 @@ checking this by themselves in their 'check' procedure." base-image)) (target (or base-target target)) (size image-size) - (operating-system os)))))) + (operating-system os) + (volatile-root? volatile-root?)))))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?))))) @@ -761,6 +763,7 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? bootloader-target target image-size image-type + volatile-root? full-boot? label container-shared-network? (mappings '()) (gc-root #f)) @@ -768,7 +771,8 @@ and TARGET arguments." bootloader; BOOTLOADER-TAGET is the target for the 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. IMAGE-TYPE is the type of image to -be built. +be built. When VOLATILE-ROOT? is #t, the root file system is mounted +volatile. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? @@ -816,6 +820,7 @@ static checks." #:label label #:image-type image-type #:image-size image-size + #:volatile-root? volatile-root? #:full-boot? full-boot? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -975,6 +980,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) (display (G_ " + --volatile for 'disk-image', make the root file system volatile")) + (display (G_ " --label=LABEL for 'disk-image', label disk image with LABEL")) (display (G_ " --save-provenance save provenance information")) @@ -1048,6 +1055,9 @@ Some ACTIONS support additional ARGS.\n")) (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) (alist-cons 'install-bootloader? #f result))) + (option '("volatile") #f #f + (lambda (opt name arg result) + (alist-cons 'volatile-root? #t result))) (option '("label") #t #f (lambda (opt name arg result) (alist-cons 'label arg result))) @@ -1109,7 +1119,8 @@ Some ACTIONS support additional ARGS.\n")) (image-type . raw) (image-size . guess) (install-bootloader? . #t) - (label . #f))) + (label . #f) + (volatile-root? . #f))) (define (verbosity-level opts) "Return the verbosity level based on OPTS, the alist of parsed options." @@ -1206,6 +1217,8 @@ resulting from command-line parsing." #:image-type (lookup-image-type-by-name (assoc-ref opts 'image-type)) #:image-size (assoc-ref opts 'image-size) + #:volatile-root? + (assoc-ref opts 'volatile-root?) #:full-boot? (assoc-ref opts 'full-boot?) #:container-shared-network? (assoc-ref opts 'container-shared-network?) diff --git a/guix/utils.scm b/guix/utils.scm index b816c355dc..a591b62f30 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -78,6 +78,7 @@ target-arm? target-64bit? cc-for-target + cxx-for-target version-compare version>? @@ -542,6 +543,11 @@ a character other than '@'." (string-append target "-gcc") "gcc")) +(define* (cxx-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-g++") + "g++")) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) |