diff options
Diffstat (limited to 'gnu/services.scm')
| -rw-r--r-- | gnu/services.scm | 102 |
1 files changed, 43 insertions, 59 deletions
diff --git a/gnu/services.scm b/gnu/services.scm index 50e76df8182..5479bfae193 100644 --- a/gnu/services.scm +++ b/gnu/services.scm | |||
| @@ -238,42 +238,33 @@ directory." | |||
| 238 | (define (cleanup-gexp _) | 238 | (define (cleanup-gexp _) |
| 239 | "Return as a monadic value a gexp to clean up /tmp and similar places upon | 239 | "Return as a monadic value a gexp to clean up /tmp and similar places upon |
| 240 | boot." | 240 | boot." |
| 241 | (define %modules | 241 | (with-monad %store-monad |
| 242 | '((guix build utils))) | 242 | (with-imported-modules '((guix build utils)) |
| 243 | 243 | (return #~(begin | |
| 244 | (mlet %store-monad ((modules (imported-modules %modules)) | 244 | (use-modules (guix build utils)) |
| 245 | (compiled (compiled-modules %modules))) | 245 | |
| 246 | (return #~(begin | 246 | ;; Clean out /tmp and /var/run. |
| 247 | (eval-when (expand load eval) | 247 | ;; |
| 248 | ;; Make sure 'use-modules' below succeeds. | 248 | ;; XXX This needs to happen before service activations, so it |
| 249 | (set! %load-path (cons #$modules %load-path)) | 249 | ;; has to be here, but this also implicitly assumes that /tmp |
| 250 | (set! %load-compiled-path | 250 | ;; and /var/run are on the root partition. |
| 251 | (cons #$compiled %load-compiled-path))) | 251 | (letrec-syntax ((fail-safe (syntax-rules () |
| 252 | 252 | ((_ exp rest ...) | |
| 253 | (use-modules (guix build utils)) | 253 | (begin |
| 254 | 254 | (catch 'system-error | |
| 255 | ;; Clean out /tmp and /var/run. | 255 | (lambda () exp) |
| 256 | ;; | 256 | (const #f)) |
| 257 | ;; XXX This needs to happen before service activations, so it | 257 | (fail-safe rest ...))) |
| 258 | ;; has to be here, but this also implicitly assumes that /tmp | 258 | ((_) |
| 259 | ;; and /var/run are on the root partition. | 259 | #t)))) |
| 260 | (letrec-syntax ((fail-safe (syntax-rules () | 260 | ;; Ignore I/O errors so the system can boot. |
| 261 | ((_ exp rest ...) | 261 | (fail-safe |
| 262 | (begin | 262 | (delete-file-recursively "/tmp") |
| 263 | (catch 'system-error | 263 | (delete-file-recursively "/var/run") |
| 264 | (lambda () exp) | 264 | (mkdir "/tmp") |
| 265 | (const #f)) | 265 | (chmod "/tmp" #o1777) |
| 266 | (fail-safe rest ...))) | 266 | (mkdir "/var/run") |
| 267 | ((_) | 267 | (chmod "/var/run" #o755)))))))) |
| 268 | #t)))) | ||
| 269 | ;; Ignore I/O errors so the system can boot. | ||
| 270 | (fail-safe | ||
| 271 | (delete-file-recursively "/tmp") | ||
| 272 | (delete-file-recursively "/var/run") | ||
| 273 | (mkdir "/tmp") | ||
| 274 | (chmod "/tmp" #o1777) | ||
| 275 | (mkdir "/var/run") | ||
| 276 | (chmod "/var/run" #o755))))))) | ||
| 277 | 268 | ||
| 278 | (define cleanup-service-type | 269 | (define cleanup-service-type |
| 279 | ;; Service that cleans things up in /tmp and similar. | 270 | ;; Service that cleans things up in /tmp and similar. |
| @@ -309,10 +300,10 @@ file." | |||
| 309 | one) | 300 | one) |
| 310 | (_ | 301 | (_ |
| 311 | (computed-file name | 302 | (computed-file name |
| 312 | #~(begin | 303 | (with-imported-modules '((guix build union)) |
| 313 | (use-modules (guix build union)) | 304 | #~(begin |
| 314 | (union-build #$output '#$things)) | 305 | (use-modules (guix build union)) |
| 315 | #:modules '((guix build union)))))) | 306 | (union-build #$output '#$things))))))) |
| 316 | 307 | ||
| 317 | (define* (activation-service->script service) | 308 | (define* (activation-service->script service) |
| 318 | "Return as a monadic value the activation script for SERVICE, a service of | 309 | "Return as a monadic value the activation script for SERVICE, a service of |
| @@ -337,29 +328,22 @@ ACTIVATION-SCRIPT-TYPE." | |||
| 337 | (cut gexp->file "activate-service" <>) | 328 | (cut gexp->file "activate-service" <>) |
| 338 | gexps)) | 329 | gexps)) |
| 339 | 330 | ||
| 340 | (mlet* %store-monad ((actions (service-activations)) | 331 | (mlet* %store-monad ((actions (service-activations))) |
| 341 | (modules (imported-modules %modules)) | ||
| 342 | (compiled (compiled-modules %modules))) | ||
| 343 | (gexp->file "activate" | 332 | (gexp->file "activate" |
| 344 | #~(begin | 333 | (with-imported-modules %modules |
| 345 | (eval-when (expand load eval) | 334 | #~(begin |
| 346 | ;; Make sure 'use-modules' below succeeds. | 335 | (use-modules (gnu build activation)) |
| 347 | (set! %load-path (cons #$modules %load-path)) | ||
| 348 | (set! %load-compiled-path | ||
| 349 | (cons #$compiled %load-compiled-path))) | ||
| 350 | |||
| 351 | (use-modules (gnu build activation)) | ||
| 352 | 336 | ||
| 353 | ;; Make sure /bin/sh is valid and current. | 337 | ;; Make sure /bin/sh is valid and current. |
| 354 | (activate-/bin/sh | 338 | (activate-/bin/sh |
| 355 | (string-append #$(canonical-package bash) "/bin/sh")) | 339 | (string-append #$(canonical-package bash) "/bin/sh")) |
| 356 | 340 | ||
| 357 | ;; Run the services' activation snippets. | 341 | ;; Run the services' activation snippets. |
| 358 | ;; TODO: Use 'load-compiled'. | 342 | ;; TODO: Use 'load-compiled'. |
| 359 | (for-each primitive-load '#$actions) | 343 | (for-each primitive-load '#$actions) |
| 360 | 344 | ||
| 361 | ;; Set up /run/current-system. | 345 | ;; Set up /run/current-system. |
| 362 | (activate-current-system))))) | 346 | (activate-current-system)))))) |
| 363 | 347 | ||
| 364 | (define (gexps->activation-gexp gexps) | 348 | (define (gexps->activation-gexp gexps) |
| 365 | "Return a gexp that runs the activation script containing GEXPS." | 349 | "Return a gexp that runs the activation script containing GEXPS." |
