Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

109 lines
3.5 KiB

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