From 722554a306be645026d75893b77863769dcd861d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 18 Sep 2014 19:18:39 +0200
Subject: [PATCH] system: Define 'device-mapping-kind', and add a 'close'
 procedure.

* gnu/system/file-systems.scm (<mapped-device-type>): New record type.
  (<mapped-device>)[command]: Remove field.
  [type]: New field.
* gnu/services/base.scm (device-mapping-service): Rename 'command'
  parameter to 'open'.  Add 'close' parameter and honor it.
* gnu/system.scm (luks-device-mapping): Rename to...
  (open-luks-device): ... this.
  (close-luks-device): New procedure.
  (luks-device-mapping): New variable.
  (device-mapping-services): Get the type of MD, and pass its 'open' and
  'close' fields to 'device-mapping-service'.
---
 gnu/services/base.scm       | 11 +++++------
 gnu/system.scm              | 24 +++++++++++++++++++-----
 gnu/system/file-systems.scm | 17 +++++++++++++++--
 3 files changed, 39 insertions(+), 13 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index bfe5f52af4..f2de85f410 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -600,19 +600,18 @@ extra rules from the packages listed in @var{rules}."
              ;; called.  Thus, make sure it is not respawned.
              (respawn? #f)))))
 
-(define (device-mapping-service target command)
+(define (device-mapping-service target open close)
   "Return a service that maps device @var{target}, a string such as
-@code{\"home\"} (meaning @code{/dev/mapper/home}), by executing @var{command},
-a gexp."
+@code{\"home\"} (meaning @code{/dev/mapper/home}).  Evaluate @var{open}, a
+gexp, to open it, and evaluate @var{close} to close it."
   (with-monad %store-monad
     (return (service
              (provision (list (symbol-append 'device-mapping-
                                              (string->symbol target))))
              (requirement '(udev))
              (documentation "Map a device node using Linux's device mapper.")
-             (start #~(lambda ()
-                        #$command))
-             (stop #~(const #f))
+             (start #~(lambda () #$open))
+             (stop #~(lambda _ (not #$close)))
              (respawn? #f)))))
 
 (define %base-services
diff --git a/gnu/system.scm b/gnu/system.scm
index db7b7e7a2f..6f0469a763 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -160,13 +160,24 @@ file."
 ;;; Services.
 ;;;
 
-(define (luks-device-mapping source target)
+(define (open-luks-device source target)
   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 'cryptsetup'."
   #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
                     "open" "--type" "luks"
                     #$source #$target)))
 
+(define (close-luks-device source target)
+  "Return a gexp that closes TARGET, a LUKS device."
+  #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+                    "close" #$target)))
+
+(define luks-device-mapping
+  ;; The type of LUKS mapped devices.
+  (mapped-device-kind
+   (open open-luks-device)
+   (close close-luks-device)))
+
 (define (other-file-system-services os)
   "Return file system services for the file systems of OS that are not marked
 as 'needed-for-boot'."
@@ -207,11 +218,14 @@ as 'needed-for-boot'."
   "Return the list of device-mapping services for OS as a monadic list."
   (sequence %store-monad
             (map (lambda (md)
-                   (let ((source  (mapped-device-source md))
-                         (target  (mapped-device-target md))
-                         (command (mapped-device-command md)))
+                   (let* ((source (mapped-device-source md))
+                          (target (mapped-device-target md))
+                          (type   (mapped-device-type md))
+                          (open   (mapped-device-kind-open type))
+                          (close  (mapped-device-kind-close type)))
                      (device-mapping-service target
-                                             (command source target))))
+                                             (open source target)
+                                             (close source target))))
                  (operating-system-mapped-devices os))))
 
 (define (essential-services os)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 90e2b0c796..ed9d70587f 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu system file-systems)
+  #:use-module (guix gexp)
   #:use-module (guix records)
   #:export (<file-system>
             file-system
@@ -43,7 +44,12 @@
             mapped-device?
             mapped-device-source
             mapped-device-target
-            mapped-device-command))
+            mapped-device-type
+
+            mapped-device-kind
+            mapped-device-kind?
+            mapped-device-kind-open
+            mapped-device-kind-close))
 
 ;;; Commentary:
 ;;;
@@ -145,6 +151,13 @@
   mapped-device?
   (source    mapped-device-source)                ;string
   (target    mapped-device-target)                ;string
-  (command   mapped-device-command))              ;source target -> gexp
+  (type      mapped-device-type))                 ;<mapped-device-kind>
+
+(define-record-type* <mapped-device-type> mapped-device-kind
+  make-mapped-device-kind
+  mapped-device-kind?
+  (open      mapped-device-kind-open)             ;source target -> gexp
+  (close     mapped-device-kind-close             ;source target -> gexp
+             (default (const #~(const #f)))))
 
 ;;; file-systems.scm ends here