gnu/system/mapped-devices.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016 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 system mapped-devices)
  20   #:use-module (guix gexp)
  21   #:use-module (guix records)
  22   #:use-module (gnu services)
  23   #:use-module (gnu services shepherd)
  24   #:autoload   (gnu packages cryptsetup) (cryptsetup)
  25   #:use-module (ice-9 match)
  26   #:export (mapped-device
  27             mapped-device?
  28             mapped-device-source
  29             mapped-device-target
  30             mapped-device-type
  31
  32             mapped-device-kind
  33             mapped-device-kind?
  34             mapped-device-kind-open
  35             mapped-device-kind-close
  36
  37             device-mapping-service-type
  38             device-mapping-service
  39
  40             luks-device-mapping))
  41
  42 ;;; Commentary:
  43 ;;;
  44 ;;; This module supports "device mapping", a concept implemented by Linux's
  45 ;;; device-mapper.
  46 ;;;
  47 ;;; Code:
  48
  49 (define-record-type* <mapped-device> mapped-device
  50   make-mapped-device
  51   mapped-device?
  52   (source    mapped-device-source)                ;string
  53   (target    mapped-device-target)                ;string
  54   (type      mapped-device-type))                 ;<mapped-device-kind>
  55
  56 (define-record-type* <mapped-device-type> mapped-device-kind
  57   make-mapped-device-kind
  58   mapped-device-kind?
  59   (open      mapped-device-kind-open)             ;source target -> gexp
  60   (close     mapped-device-kind-close             ;source target -> gexp
  61              (default (const #~(const #f)))))
  62
  63 \f
  64 ;;;
  65 ;;; Device mapping as a Shepherd service.
  66 ;;;
  67
  68 (define device-mapping-service-type
  69   (shepherd-service-type
  70    'device-mapping
  71    (match-lambda
  72      ((target open close)
  73       (shepherd-service
  74        (provision (list (symbol-append 'device-mapping- (string->symbol target))))
  75        (requirement '(udev))
  76        (documentation "Map a device node using Linux's device mapper.")
  77        (start #~(lambda () #$open))
  78        (stop #~(lambda _ (not #$close)))
  79        (respawn? #f))))))
  80
  81 (define (device-mapping-service target open close)
  82   "Return a service that maps device @var{target}, a string such as
  83 @code{\"home\"} (meaning @code{/dev/mapper/home}).  Evaluate @var{open}, a
  84 gexp, to open it, and evaluate @var{close} to close it."
  85   (service device-mapping-service-type
  86            (list target open close)))
  87
  88 \f
  89 ;;;
  90 ;;; Common device mappings.
  91 ;;;
  92
  93 (define (open-luks-device source target)
  94   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
  95 'cryptsetup'."
  96   #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
  97                     "open" "--type" "luks"
  98                     #$source #$target)))
  99
 100 (define (close-luks-device source target)
 101   "Return a gexp that closes TARGET, a LUKS device."
 102   #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
 103                     "close" #$target)))
 104
 105 (define luks-device-mapping
 106   ;; The type of LUKS mapped devices.
 107   (mapped-device-kind
 108    (open open-luks-device)
 109    (close close-luks-device)))
 110
 111 ;;; mapped-devices.scm ends here