summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/gnu.scm2
-rw-r--r--guix/build/syscalls.scm15
-rw-r--r--guix/gnu-maintenance.scm14
-rw-r--r--guix/http-client.scm56
-rw-r--r--guix/scripts/graph.scm8
-rw-r--r--guix/scripts/system.scm119
-rw-r--r--guix/utils.scm7
7 files changed, 190 insertions, 31 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 3be83468eb..c83c50b76e 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -204,7 +204,7 @@ runs `make distcheck' and whose result is one or more source tarballs."
(let ((ref (lambda (module var)
(module-ref (resolve-interface module) var))))
`(,@(package-native-inputs p)
- ("autoconf" ,(ref '(gnu packages autotools) 'autoconf))
+ ("autoconf" ,((ref '(gnu packages autotools) 'autoconf-wrapper)))
("automake" ,(ref '(gnu packages autotools) 'automake))
("libtool" ,(ref '(gnu packages autotools) 'libtool))
("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 2c2fbde0a3..a3b68c4537 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -315,10 +315,16 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(define CLONE_NEWNET #x40000000)
;; The libc interface to sys_clone is not useful for Scheme programs, so the
-;; low-level system call is wrapped instead.
+;; low-level system call is wrapped instead. The 'syscall' function is
+;; declared in <unistd.h> as a variadic function; in practice, it expects 6
+;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S.
(define clone
(let* ((ptr (dynamic-func "syscall" (dynamic-link)))
- (proc (pointer->procedure int ptr (list int int '*)))
+ (proc (pointer->procedure long ptr
+ (list long ;sysno
+ unsigned-long ;flags
+ '* '* '*
+ '*)))
;; TODO: Don't do this.
(syscall-id (match (utsname:machine (uname))
("i686" 120)
@@ -329,7 +335,10 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
"Create a new child process by duplicating the current parent process.
Unlike the fork system call, clone accepts FLAGS that specify which resources
are shared between the parent and child processes."
- (let ((ret (proc syscall-id flags %null-pointer))
+ (let ((ret (proc syscall-id flags
+ %null-pointer ;child stack
+ %null-pointer %null-pointer ;ptid & ctid
+ %null-pointer)) ;unused
(err (errno)))
(if (= ret -1)
(throw 'system-error "clone" "~d: ~A"
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index ac83df40a3..e09df4b3ef 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -116,8 +116,10 @@
(doc-urls gnu-package-doc-urls) ; list of strings
(download-url gnu-package-download-url))
-(define (official-gnu-packages)
- "Return a list of records, which are GNU packages."
+(define* (official-gnu-packages
+ #:optional (fetch http-fetch/cached))
+ "Return a list of records, which are GNU packages. Use FETCH,
+to fetch the list of GNU packages over HTTP."
(define (read-records port)
;; Return a list of alists. Each alist contains fields of a GNU
;; package.
@@ -129,8 +131,7 @@
(cons alist result)))))
(define official-description
- (let ((db (read-records (http-fetch %package-description-url
- #:text? #t))))
+ (let ((db (read-records (fetch %package-description-url #:text? #t))))
(lambda (name)
;; Return the description found upstream for package NAME, or #f.
(and=> (find (lambda (alist)
@@ -160,7 +161,10 @@
"doc-url"
"download-url")
'("doc-url" "language"))))
- (read-records (http-fetch %package-list-url #:text? #t))))
+ (let* ((port (fetch %package-list-url #:text? #t))
+ (lst (read-records port)))
+ (close-port port)
+ lst)))
(define (find-packages regexp)
"Find GNU packages which satisfy REGEXP."
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 9861ec80cb..8d1cc9b8f3 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -23,6 +23,8 @@
#:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
@@ -30,6 +32,8 @@
#:use-module (rnrs bytevectors)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module ((guix build utils)
+ #:select (mkdir-p dump-port))
#:use-module ((guix build download)
#:select (open-socket-for-uri resolve-uri-reference))
#:re-export (open-socket-for-uri)
@@ -39,7 +43,10 @@
http-get-error-code
http-get-error-reason
- http-fetch))
+ http-fetch
+
+ %http-cache-ttl
+ http-fetch/cached))
;;; Commentary:
;;;
@@ -229,4 +236,51 @@ Raise an '&http-get-error' condition if downloading fails."
(&message
(message "download failed"))))))))))
+
+;;;
+;;; Caching.
+;;;
+
+(define (%http-cache-ttl)
+ ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
+ (make-parameter
+ (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
+ string->number*)
+ 36))))
+
+(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?)
+ "Like 'http-fetch', return an input port, but cache its contents in
+~/.cache/guix. The cache remains valid for TTL seconds."
+ (let* ((directory (string-append (cache-directory) "/http/"
+ (uri-host uri)))
+ (file (string-append directory "/"
+ (basename (uri-path uri)))))
+ (define (update-cache)
+ ;; Update the cache and return an input port.
+ (let ((port (http-fetch uri #:text? text?)))
+ (mkdir-p directory)
+ (call-with-output-file file
+ (cut dump-port port <>))
+ (close-port port)
+ (open-input-file file)))
+
+ (define (old? port)
+ ;; Return true if PORT has passed TTL.
+ (let* ((s (stat port))
+ (now (current-time time-utc)))
+ (< (+ (stat:mtime s) ttl) (time-second now))))
+
+ (catch 'system-error
+ (lambda ()
+ (let ((port (open-input-file file)))
+ (if (old? port)
+ (begin
+ (close-port port)
+ (update-cache))
+ port)))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (update-cache)
+ (apply throw args))))))
+
;;; http-client.scm ends here
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 725ae42030..734a47719a 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -322,10 +322,12 @@ substitutes."
(define* (export-graph sinks port
#:key
+ reverse-edges?
(node-type %package-node-type)
(backend %graphviz-backend))
"Write to PORT the representation of the DAG with the given SINKS, using the
-given BACKEND. Use NODE-TYPE to traverse the DAG."
+given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is
+true, draw reverse arrows."
(match backend
(($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
(emit-prologue (node-type-name node-type) port)
@@ -349,7 +351,9 @@ given BACKEND. Use NODE-TYPE to traverse the DAG."
dependencies)))
(emit-node id (node-label head) port)
(for-each (lambda (dependency dependency-id)
- (emit-edge id dependency-id port))
+ (if reverse-edges?
+ (emit-edge dependency-id id port)
+ (emit-edge id dependency-id port)))
dependencies ids)
(loop (append dependencies tail)
(set-insert id visited)))))))))))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 71b92dacc7..b5da57a9ce 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -28,12 +28,15 @@
#:use-module (guix profiles)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix scripts graph)
#:use-module (guix build utils)
#:use-module (gnu build install)
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system vm)
#:use-module (gnu system grub)
+ #:use-module (gnu services)
+ #:use-module (gnu services dmd)
#:use-module (gnu packages grub)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
@@ -280,6 +283,50 @@ it atomically, and then run OS's activation script."
;;;
+;;; Graphs.
+;;;
+
+(define (service-node-label service)
+ "Return a label to represent SERVICE."
+ (let ((type (service-kind service))
+ (value (service-parameters service)))
+ (string-append (symbol->string (service-type-name type))
+ (cond ((or (number? value) (symbol? value))
+ (string-append " " (object->string value)))
+ ((string? value)
+ (string-append " " value))
+ ((file-system? value)
+ (string-append " " (file-system-mount-point value)))
+ (else
+ "")))))
+
+(define (service-node-type services)
+ "Return a node type for SERVICES. Since <service> instances are not
+self-contained (they express dependencies on service types, not on services),
+we have to create the 'edges' procedure dynamically as a function of the full
+list of services."
+ (node-type
+ (name "service")
+ (description "the DAG of services")
+ (identifier (lift1 object-address %store-monad))
+ (label service-node-label)
+ (edges (lift1 (service-back-edges services) %store-monad))))
+
+(define (dmd-service-node-label service)
+ "Return a label for a node representing a <dmd-service>."
+ (string-join (map symbol->string (dmd-service-provision service))))
+
+(define (dmd-service-node-type services)
+ "Return a node type for SERVICES, a list of <dmd-service>."
+ (node-type
+ (name "dmd-service")
+ (description "the dependency graph of dmd services")
+ (identifier (lift1 dmd-service-node-label %store-monad))
+ (label dmd-service-node-label)
+ (edges (lift1 (dmd-service-back-edges services) %store-monad))))
+
+
+;;;
;;; Action.
;;;
@@ -366,6 +413,29 @@ building anything."
;; All we had to do was to build SYS.
(return (derivation->output-path sys))))))))
+(define (export-extension-graph os port)
+ "Export the service extension graph of OS to PORT."
+ (let* ((services (operating-system-services os))
+ (boot (find (lambda (service)
+ (eq? (service-kind service) boot-service-type))
+ services)))
+ (export-graph (list boot) (current-output-port)
+ #:node-type (service-node-type services)
+ #:reverse-edges? #t)))
+
+(define (export-dmd-graph os port)
+ "Export the graph of dmd services of OS to PORT."
+ (let* ((services (operating-system-services os))
+ (pid1 (fold-services services
+ #:target-type dmd-root-service-type))
+ (dmds (service-parameters pid1)) ;the list of <dmd-service>
+ (sinks (filter (lambda (service)
+ (null? (dmd-service-requirement service)))
+ dmds)))
+ (export-graph sinks (current-output-port)
+ #:node-type (dmd-service-node-type dmds)
+ #:reverse-edges? #t)))
+
;;;
;;; Options.
@@ -388,7 +458,11 @@ Build the operating system declared in FILE according to ACTION.\n"))
(display (_ "\
disk-image build a disk image, suitable for a USB stick\n"))
(display (_ "\
- init initialize a root file system to run GNU.\n"))
+ init initialize a root file system to run GNU\n"))
+ (display (_ "\
+ extension-graph emit the service extension graph in Dot format\n"))
+ (display (_ "\
+ dmd-graph emit the graph of dmd services in Dot format\n"))
(show-build-options-help)
(display (_ "
@@ -496,16 +570,17 @@ Build the operating system declared in FILE according to ACTION.\n"))
(alist-cons 'argument arg result)
(let ((action (string->symbol arg)))
(case action
- ((build vm vm-image disk-image reconfigure init)
+ ((build vm vm-image disk-image reconfigure init
+ extension-graph dmd-graph)
(alist-cons 'action action result))
(else (leave (_ "~a: unknown action~%") action))))))
(define (match-pair car)
;; Return a procedure that matches a pair with CAR.
(match-lambda
- ((head . tail)
- (and (eq? car head) tail))
- (_ #f)))
+ ((head . tail)
+ (and (eq? car head) tail))
+ (_ #f)))
(define (option-arguments opts)
;; Extract the plain arguments from OPTS.
@@ -561,20 +636,26 @@ Build the operating system declared in FILE according to ACTION.\n"))
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
- (perform-action action os
- #:dry-run? dry?
- #:derivations-only? (assoc-ref opts
- 'derivations-only?)
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:image-size (assoc-ref opts 'image-size)
- #:full-boot? (assoc-ref opts 'full-boot?)
- #:mappings (filter-map (match-lambda
- (('file-system-mapping . m)
- m)
- (_ #f))
- opts)
- #:grub? grub?
- #:target target #:device device))
+ (case action
+ ((extension-graph)
+ (export-extension-graph os (current-output-port)))
+ ((dmd-graph)
+ (export-dmd-graph os (current-output-port)))
+ (else
+ (perform-action action os
+ #:dry-run? dry?
+ #:derivations-only? (assoc-ref opts
+ 'derivations-only?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:image-size (assoc-ref opts 'image-size)
+ #:full-boot? (assoc-ref opts 'full-boot?)
+ #:mappings (filter-map (match-lambda
+ (('file-system-mapping . m)
+ m)
+ (_ #f))
+ opts)
+ #:grub? grub?
+ #:target target #:device device))))
#:system system))))
;;; system.scm ends here
diff --git a/guix/utils.scm b/guix/utils.scm
index 0802a1b67a..190b787185 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -81,6 +81,7 @@
fold-tree
fold-tree-leaves
split
+ cache-directory
filtered-port
compressed-port
@@ -703,6 +704,12 @@ elements after E."
((head . tail)
(loop tail (cons head acc))))))
+(define (cache-directory)
+ "Return the cache directory for Guix, by default ~/.cache/guix."
+ (or (getenv "XDG_CONFIG_HOME")
+ (and=> (getenv "HOME")
+ (cut string-append <> "/.cache/guix"))))
+
;;;
;;; Source location.
generated by cgit v1.2.3 (git 2.50.1) at 2025-10-29 20:28:30 +0000