gnu/services/dmd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services dmd)
  20   #:use-module (guix ui)
  21   #:use-module (guix sets)
  22   #:use-module (guix gexp)
  23   #:use-module (guix store)
  24   #:use-module (guix monads)
  25   #:use-module (guix records)
  26   #:use-module (guix derivations)                 ;imported-modules, etc.
  27   #:use-module (gnu services)
  28   #:use-module (gnu packages admin)
  29   #:use-module (ice-9 match)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-35)
  33   #:export (dmd-root-service-type
  34             %dmd-root-service
  35             dmd-service-type
  36
  37             dmd-service
  38             dmd-service?
  39             dmd-service-documentation
  40             dmd-service-provision
  41             dmd-service-requirement
  42             dmd-service-respawn?
  43             dmd-service-start
  44             dmd-service-stop
  45             dmd-service-auto-start?))
  46
  47 ;;; Commentary:
  48 ;;;
  49 ;;; Instantiating system services as a dmd configuration file.
  50 ;;;
  51 ;;; Code:
  52
  53
  54 (define (dmd-boot-gexp services)
  55   (mlet %store-monad ((dmd-conf (dmd-configuration-file services)))
  56     (return #~(begin
  57                 ;; Keep track of the booted system.
  58                 (false-if-exception (delete-file "/run/booted-system"))
  59                 (symlink (readlink "/run/current-system")
  60                          "/run/booted-system")
  61
  62                 ;; Close any remaining open file descriptors to be on the safe
  63                 ;; side.  This must be the very last thing we do, because
  64                 ;; Guile has internal FDs such as 'sleep_pipe' that need to be
  65                 ;; alive.
  66                 (let loop ((fd 3))
  67                   (when (< fd 1024)
  68                     (false-if-exception (close-fdes fd))
  69                     (loop (+ 1 fd))))
  70
  71                 ;; Start dmd.
  72                 (execl (string-append #$dmd "/bin/dmd")
  73                        "dmd" "--config" #$dmd-conf)))))
  74
  75 (define dmd-root-service-type
  76   (service-type
  77    (name 'dmd-root)
  78    ;; Extending the root dmd service (aka. PID 1) happens by concatenating the
  79    ;; list of services provided by the extensions.
  80    (compose concatenate)
  81    (extend append)
  82    (extensions (list (service-extension boot-service-type dmd-boot-gexp)))))
  83
  84 (define %dmd-root-service
  85   ;; The root dmd service, aka. PID 1.  Its parameter is a list of
  86   ;; <dmd-service> objects.
  87   (service dmd-root-service-type '()))
  88
  89 (define-syntax-rule (dmd-service-type service-name proc)
  90   "Return a <service-type> denoting a simple dmd service--i.e., the type for a
  91 service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
  92   (service-type
  93    (name service-name)
  94    (extensions
  95     (list (service-extension dmd-root-service-type
  96                              (compose list proc))))))
  97
  98 (define-record-type* <dmd-service>
  99   dmd-service make-dmd-service
 100   dmd-service?
 101   (documentation dmd-service-documentation        ;string
 102                  (default "[No documentation.]"))
 103   (provision     dmd-service-provision)           ;list of symbols
 104   (requirement   dmd-service-requirement          ;list of symbols
 105                  (default '()))
 106   (respawn?      dmd-service-respawn?             ;Boolean
 107                  (default #t))
 108   (start         dmd-service-start)               ;g-expression (procedure)
 109   (stop          dmd-service-stop                 ;g-expression (procedure)
 110                  (default #~(const #f)))
 111   (auto-start?   dmd-service-auto-start?          ;Boolean
 112                  (default #t)))
 113
 114
 115 (define (assert-no-duplicates services)
 116   "Raise an error if SERVICES provide the same dmd service more than once.
 117
 118 This is a constraint that dmd's 'register-service' verifies but we'd better
 119 verify it here statically than wait until PID 1 halts with an assertion
 120 failure."
 121   (fold (lambda (service set)
 122           (define (assert-unique symbol)
 123             (when (set-contains? set symbol)
 124               (raise (condition
 125                       (&message
 126                        (message
 127                         (format #f (_ "service '~a' provided more than once")
 128                                 symbol)))))))
 129
 130           (for-each assert-unique (dmd-service-provision service))
 131           (fold set-insert set (dmd-service-provision service)))
 132         (setq)
 133         services))
 134
 135 (define (dmd-configuration-file services)
 136   "Return the dmd configuration file for SERVICES."
 137   (define modules
 138     ;; Extra modules visible to dmd.conf.
 139     '((guix build syscalls)
 140       (gnu build file-systems)
 141       (guix build utils)))
 142
 143   (assert-no-duplicates services)
 144
 145   (mlet %store-monad ((modules  (imported-modules modules))
 146                       (compiled (compiled-modules modules)))
 147     (define config
 148       #~(begin
 149           (eval-when (expand load eval)
 150             (set! %load-path (cons #$modules %load-path))
 151             (set! %load-compiled-path
 152                   (cons #$compiled %load-compiled-path)))
 153
 154           (use-modules (ice-9 ftw)
 155                        (guix build syscalls)
 156                        (guix build utils)
 157                        ((gnu build file-systems)
 158                         #:select (check-file-system canonicalize-device-spec)))
 159
 160           (register-services
 161            #$@(map (lambda (service)
 162                      #~(make <service>
 163                          #:docstring '#$(dmd-service-documentation service)
 164                          #:provides '#$(dmd-service-provision service)
 165                          #:requires '#$(dmd-service-requirement service)
 166                          #:respawn? '#$(dmd-service-respawn? service)
 167                          #:start #$(dmd-service-start service)
 168                          #:stop #$(dmd-service-stop service)))
 169                    services))
 170
 171           ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it.
 172           (setenv "PATH" "/run/current-system/profile/bin")
 173
 174           (format #t "starting services...~%")
 175           (for-each start
 176                     '#$(append-map dmd-service-provision
 177                                    (filter dmd-service-auto-start?
 178                                            services)))))
 179
 180     (gexp->file "dmd.conf" config)))
 181
 182 ;;; dmd.scm ends here