diff options
Diffstat (limited to 'gnu/system/dmd.scm')
| -rw-r--r-- | gnu/system/dmd.scm | 172 |
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 |