aboutsummaryrefslogtreecommitdiff
path: root/gnu/system/dmd.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system/dmd.scm')
-rw-r--r--gnu/system/dmd.scm172
1 files changed, 84 insertions, 88 deletions
diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 4d3b4b31f0..946b6a7937 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -31,6 +31,7 @@
#:select (net-tools))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (guix monads)
#:export (service?
service
service-provision
@@ -69,53 +70,51 @@
(inputs service-inputs ; list of inputs
(default '())))
-(define (host-name-service store name)
+(define (host-name-service name)
"Return a service that sets the host name to NAME."
- (service
- (provision '(host-name))
- (start `(lambda _
- (sethostname ,name)))
- (respawn? #f)))
-
-(define (mingetty-service store tty)
+ (with-monad %store-monad
+ (return (service
+ (provision '(host-name))
+ (start `(lambda _
+ (sethostname ,name)))
+ (respawn? #f)))))
+
+(define (mingetty-service tty)
"Return a service to run mingetty on TTY."
- (let* ((mingetty-drv (package-derivation store mingetty))
- (mingetty-bin (string-append (derivation->output-path mingetty-drv)
- "/sbin/mingetty")))
- (service
- (provision (list (symbol-append 'term- (string->symbol tty))))
+ (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")))
+ (return
+ (service
+ (provision (list (symbol-append 'term- (string->symbol tty))))
- ;; Since the login prompt shows the host name, wait for the 'host-name'
- ;; service to be done.
- (requirement '(host-name))
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done.
+ (requirement '(host-name))
- (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
- (inputs `(("mingetty" ,mingetty))))))
+ (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
+ (inputs `(("mingetty" ,mingetty)))))))
-(define* (nscd-service store
- #:key (glibc glibc-final))
+(define* (nscd-service #:key (glibc glibc-final))
"Return a service that runs libc's name service cache daemon (nscd)."
- (let ((nscd (string-append (package-output store glibc) "/sbin/nscd")))
- (service
- (provision '(nscd))
- (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
-
- ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
- ;; uses the broken 'opt-lambda' macro.
- (stop `(lambda* (#:optional (signal SIGTERM))
- (lambda (pid . args)
- (kill pid signal)
- #f)))
-
- (respawn? #f)
- (inputs `(("glibc" ,glibc))))))
-
-(define (syslog-service store)
+ (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
+ (return (service
+ (provision '(nscd))
+ (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
+
+ ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
+ ;; uses the broken 'opt-lambda' macro.
+ (stop `(lambda* (#:optional (signal SIGTERM))
+ (lambda (pid . args)
+ (kill pid signal)
+ #f)))
+
+ (respawn? #f)
+ (inputs `(("glibc" ,glibc)))))))
+
+(define (syslog-service)
"Return a service that runs 'syslogd' with reasonable default settings."
- (define syslog.conf
- ;; Snippet adapted from the GNU inetutils manual.
- (add-text-to-store store "syslog.conf" "
+ ;; Snippet adapted from the GNU inetutils manual.
+ (define contents "
# Log all kernel messages, authentication messages of
# level notice or higher and anything of level err or
# higher to the console.
@@ -134,31 +133,30 @@
# Log all the mail messages in one place.
mail.* /var/log/maillog
-"))
-
- (let* ((inetutils-drv (package-derivation store inetutils))
- (syslogd (string-append (derivation->output-path inetutils-drv)
- "/libexec/syslogd")))
- (service
- (provision '(syslogd))
- (start `(make-forkexec-constructor ,syslogd
- "--rcfile" ,syslog.conf))
- (inputs `(("inetutils" ,inetutils)
- ("syslog.conf" ,syslog.conf))))))
-
-(define* (guix-service store #:key (guix guix) (builder-group "guixbuild"))
+")
+
+ (mlet %store-monad
+ ((syslog.conf (text-file "syslog.conf" contents))
+ (syslogd (package-file inetutils "libexec/syslogd")))
+ (return
+ (service
+ (provision '(syslogd))
+ (start `(make-forkexec-constructor ,syslogd
+ "--rcfile" ,syslog.conf))
+ (inputs `(("inetutils" ,inetutils)
+ ("syslog.conf" ,syslog.conf)))))))
+
+(define* (guix-service #:key (guix guix) (builder-group "guixbuild"))
"Return a service that runs the build daemon from GUIX."
- (let* ((drv (package-derivation store guix))
- (daemon (string-append (derivation->output-path drv)
- "/bin/guix-daemon")))
- (service
- (provision '(guix-daemon))
- (start `(make-forkexec-constructor ,daemon
- "--build-users-group"
- ,builder-group))
- (inputs `(("guix" ,guix))))))
-
-(define* (static-networking-service store interface ip
+ (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")))
+ (return (service
+ (provision '(guix-daemon))
+ (start `(make-forkexec-constructor ,daemon
+ "--build-users-group"
+ ,builder-group))
+ (inputs `(("guix" ,guix)))))))
+
+(define* (static-networking-service interface ip
#:key
gateway
(inetutils inetutils)
@@ -169,31 +167,30 @@ true, it must be a string specifying the default network gateway."
;; TODO: Eventually we should do this using Guile's networking procedures,
;; like 'configure-qemu-networking' does, but the patch that does this is
;; not yet in stock Guile.
- (let ((ifconfig (string-append (package-output store inetutils)
- "/bin/ifconfig"))
- (route (string-append (package-output store net-tools)
- "/sbin/route")))
- (service
- (provision '(networking))
- (start `(lambda _
- (and (zero? (system* ,ifconfig ,interface ,ip "up"))
- ,(if gateway
- `(begin
- (sleep 3) ; XXX
- (zero? (system* ,route "add" "-net" "default"
- "gw" ,gateway)))
- #t))))
- (stop `(lambda _
- (system* ,ifconfig ,interface "down")
- (system* ,route "del" "-net" "default")))
- (respawn? #f)
- (inputs `(("inetutils" ,inetutils)
- ,@(if gateway
- `(("net-tools" ,net-tools))
- '()))))))
+ (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig"))
+ (route (package-file net-tools "sbin/route")))
+ (return
+ (service
+ (provision '(networking))
+ (start `(lambda _
+ (and (zero? (system* ,ifconfig ,interface ,ip "up"))
+ ,(if gateway
+ `(begin
+ (sleep 3) ; XXX
+ (zero? (system* ,route "add" "-net" "default"
+ "gw" ,gateway)))
+ #t))))
+ (stop `(lambda _
+ (system* ,ifconfig ,interface "down")
+ (system* ,route "del" "-net" "default")))
+ (respawn? #f)
+ (inputs `(("inetutils" ,inetutils)
+ ,@(if gateway
+ `(("net-tools" ,net-tools))
+ '())))))))
-(define (dmd-configuration-file store services)
+(define (dmd-configuration-file services)
"Return the dmd configuration file for SERVICES."
(define config
`(begin
@@ -209,7 +206,6 @@ true, it must be a string specifying the default network gateway."
services))
(for-each start ',(append-map service-provision services))))
- (add-text-to-store store "dmd.conf"
- (object->string config)))
+ (text-file "dmd.conf" (object->string config)))
;;; dmd.scm ends here
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-14 19:48:33 +0000