summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/pack.scm161
-rw-r--r--guix/scripts/weather.scm71
2 files changed, 137 insertions, 95 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c8d8546e29..652b4c63c4 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -365,6 +365,21 @@ added to the pack."
(define database #+database)
(define entry-point #$entry-point)
+ (define (mksquashfs args)
+ (apply invoke "mksquashfs"
+ `(,@args
+
+ ;; Do not create a "recovery file" when appending to the
+ ;; file system since it's useless in this case.
+ "-no-recovery"
+
+ ;; Set file times and the file system creation time to
+ ;; one second after the Epoch.
+ "-all-time" "1" "-mkfs-time" "1"
+
+ ;; Reset all UIDs and GIDs.
+ "-force-uid" "0" "-force-gid" "0")))
+
(setenv "PATH" (string-append #$archiver "/bin"))
;; We need an empty file in order to have a valid file argument when
@@ -376,92 +391,90 @@ added to the pack."
;; Add all store items. Unfortunately mksquashfs throws away all
;; ancestor directories and only keeps the basename. We fix this
;; in the following invocations of mksquashfs.
- (apply invoke "mksquashfs"
- `(,@(map store-info-item
- (call-with-input-file "profile"
- read-reference-graph))
- #$environment
- ,#$output
-
- ;; Do not perform duplicate checking because we
- ;; don't have any dupes.
- "-no-duplicates"
- "-comp"
- ,#+(compressor-name compressor)))
+ (mksquashfs `(,@(map store-info-item
+ (call-with-input-file "profile"
+ read-reference-graph))
+ #$environment
+ ,#$output
+
+ ;; Do not perform duplicate checking because we
+ ;; don't have any dupes.
+ "-no-duplicates"
+ "-comp"
+ ,#+(compressor-name compressor)))
;; Here we reparent the store items. For each sub-directory of
;; the store prefix we need one invocation of "mksquashfs".
(for-each (lambda (dir)
- (apply invoke "mksquashfs"
- `(".empty"
- ,#$output
- "-root-becomes" ,dir)))
+ (mksquashfs `(".empty"
+ ,#$output
+ "-root-becomes" ,dir)))
(reverse (string-tokenize (%store-directory)
(char-set-complement (char-set #\/)))))
;; Add symlinks and mount points.
- (apply invoke "mksquashfs"
- `(".empty"
- ,#$output
- ;; Create SYMLINKS via pseudo file definitions.
- ,@(append-map
- (match-lambda
- ((source '-> target)
- ;; Create relative symlinks to work around a bug in
- ;; Singularity 2.x:
- ;; https://bugs.gnu.org/34913
- ;; https://github.com/sylabs/singularity/issues/1487
- (let ((target (string-append #$profile "/" target)))
- (list "-p"
- (string-join
- ;; name s mode uid gid symlink
- (list source
- "s" "777" "0" "0"
- (relative-file-name (dirname source)
- target)))))))
- '#$symlinks*)
-
- "-p" "/.singularity.d d 555 0 0"
-
- ;; Create the environment file.
- "-p" "/.singularity.d/env d 555 0 0"
- "-p" ,(string-append
- "/.singularity.d/env/90-environment.sh s 777 0 0 "
- (relative-file-name "/.singularity.d/env"
- #$environment))
-
- ;; Create /.singularity.d/actions, and optionally the 'run'
- ;; script, used by 'singularity run'.
- "-p" "/.singularity.d/actions d 555 0 0"
-
- ,@(if entry-point
- `(;; This one if for Singularity 2.x.
- "-p"
- ,(string-append
- "/.singularity.d/actions/run s 777 0 0 "
- (relative-file-name "/.singularity.d/actions"
- (string-append #$profile "/"
- entry-point)))
-
- ;; This one is for Singularity 3.x.
- "-p"
- ,(string-append
- "/.singularity.d/runscript s 777 0 0 "
- (relative-file-name "/.singularity.d"
- (string-append #$profile "/"
- entry-point))))
- '())
-
- ;; Create empty mount points.
- "-p" "/proc d 555 0 0"
- "-p" "/sys d 555 0 0"
- "-p" "/dev d 555 0 0"
- "-p" "/home d 555 0 0"))
+ (mksquashfs
+ `(".empty"
+ ,#$output
+ ;; Create SYMLINKS via pseudo file definitions.
+ ,@(append-map
+ (match-lambda
+ ((source '-> target)
+ ;; Create relative symlinks to work around a bug in
+ ;; Singularity 2.x:
+ ;; https://bugs.gnu.org/34913
+ ;; https://github.com/sylabs/singularity/issues/1487
+ (let ((target (string-append #$profile "/" target)))
+ (list "-p"
+ (string-join
+ ;; name s mode uid gid symlink
+ (list source
+ "s" "777" "0" "0"
+ (relative-file-name (dirname source)
+ target)))))))
+ '#$symlinks*)
+
+ "-p" "/.singularity.d d 555 0 0"
+
+ ;; Create the environment file.
+ "-p" "/.singularity.d/env d 555 0 0"
+ "-p" ,(string-append
+ "/.singularity.d/env/90-environment.sh s 777 0 0 "
+ (relative-file-name "/.singularity.d/env"
+ #$environment))
+
+ ;; Create /.singularity.d/actions, and optionally the 'run'
+ ;; script, used by 'singularity run'.
+ "-p" "/.singularity.d/actions d 555 0 0"
+
+ ,@(if entry-point
+ `(;; This one if for Singularity 2.x.
+ "-p"
+ ,(string-append
+ "/.singularity.d/actions/run s 777 0 0 "
+ (relative-file-name "/.singularity.d/actions"
+ (string-append #$profile "/"
+ entry-point)))
+
+ ;; This one is for Singularity 3.x.
+ "-p"
+ ,(string-append
+ "/.singularity.d/runscript s 777 0 0 "
+ (relative-file-name "/.singularity.d"
+ (string-append #$profile "/"
+ entry-point))))
+ '())
+
+ ;; Create empty mount points.
+ "-p" "/proc d 555 0 0"
+ "-p" "/sys d 555 0 0"
+ "-p" "/dev d 555 0 0"
+ "-p" "/home d 555 0 0"))
(when database
;; Initialize /var/guix.
(install-database-and-gc-roots "var-etc" database #$profile)
- (invoke "mksquashfs" "var-etc" #$output)))))
+ (mksquashfs `("var-etc" ,#$output))))))
(gexp->derivation (string-append name
(compressor-extension compressor)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 629844768a..a9e0cba92a 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -175,8 +175,11 @@ about the derivations queued, as is the case with Hydra."
#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* (report-server-coverage server items
+ #:key display-missing?)
+ "Report the subset of ITEMS available as substitutes on SERVER.
+When DISPLAY-MISSING? is true, display the list of missing substitutes.
+Return the coverage ratio, an exact number between 0 and 1."
(define MiB (* (expt 2 20) 1.))
(format #t (G_ "looking for ~h store items on ~a...~%")
@@ -260,7 +263,16 @@ are queued~%")
system
(* (throughput builds build-timestamp)
3600.))))
- (histogram build-system cons '() latest)))))))
+ (histogram build-system cons '() latest))))
+
+ (when (and display-missing? (not (null? missing)))
+ (newline)
+ (format #t (G_ "Substitutes are missing for the following items:~%"))
+ (format #t "~{ ~a~%~}" missing))
+
+ ;; Return the coverage ratio.
+ (let ((total (length items)))
+ (/ (- total (length missing)) total)))))
;;;
@@ -281,6 +293,8 @@ Report the availability of substitutes.\n"))
show substitute coverage for packages with at least
COUNT dependents"))
(display (G_ "
+ --display-missing display the list of missing substitutes"))
+ (display (G_ "
-s, --system=SYSTEM consider substitutes for SYSTEM--e.g., \"i686-linux\""))
(newline)
(display (G_ "
@@ -318,6 +332,9 @@ Report the availability of substitutes.\n"))
(alist-cons 'coverage
(if arg (string->number* arg) 0)
result)))
+ (option '("display-missing") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'display-missing? #t result)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg result)))))
@@ -487,17 +504,19 @@ SERVER. Display information for packages with at least THRESHOLD dependents."
(define (guix-weather . args)
(define (package-list opts)
;; Return the package list specified by OPTS.
- (let ((file (assoc-ref opts 'manifest))
- (base (filter-map (match-lambda
- (('argument . spec)
- (specification->package spec))
- (_
- #f))
- opts)))
- (if (and (not file) (null? base))
+ (let ((files (filter-map (match-lambda
+ (('manifest . file) file)
+ (_ #f))
+ opts))
+ (base (filter-map (match-lambda
+ (('argument . spec)
+ (specification->package spec))
+ (_
+ #f))
+ opts)))
+ (if (and (null? files) (null? base))
(all-packages)
- (append base
- (if file (load-manifest file) '())))))
+ (append base (append-map load-manifest files)))))
(with-error-handling
(parameterize ((current-terminal-columns (terminal-columns))
@@ -524,14 +543,24 @@ SERVER. Display information for packages with at least THRESHOLD dependents."
(lambda (system)
(package-outputs packages system))
systems))))))
- (for-each (lambda (server)
- (report-server-coverage server items)
- (match (assoc-ref opts 'coverage)
- (#f #f)
- (threshold
- (report-package-coverage server packages systems
- #:threshold threshold))))
- urls)))))
+ (exit
+ (every (lambda (server)
+ (define coverage
+ (report-server-coverage server items
+ #:display-missing?
+ (assoc-ref opts 'display-missing?)))
+ (match (assoc-ref opts 'coverage)
+ (#f #f)
+ (threshold
+ ;; PACKAGES may include non-package objects coming from a
+ ;; manifest. Filter them out.
+ (report-package-coverage server
+ (filter package? packages)
+ systems
+ #:threshold threshold)))
+
+ (= 1 coverage))
+ urls))))))
;;; Local Variables:
;;; eval: (put 'let/time 'scheme-indent-function 1)
generated by cgit v1.2.3 (git 2.25.4) at 2024-06-10 14:28:12 +0000