123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213 |
- (define-module (gnu system mapped-devices)
- #:use-module (guix gexp)
- #:use-module (guix records)
- #:use-module (guix modules)
- #:use-module (guix i18n)
- #:use-module ((guix utils)
- #:select (source-properties->location
- &error-location))
- #:use-module (gnu services)
- #:use-module (gnu services shepherd)
- #:use-module (gnu system uuid)
- #:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
- #:autoload (gnu packages cryptsetup) (cryptsetup-static)
- #:autoload (gnu packages linux) (mdadm-static)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:use-module (ice-9 match)
- #:export (mapped-device
- mapped-device?
- mapped-device-source
- mapped-device-target
- mapped-device-type
- mapped-device-location
- mapped-device-kind
- mapped-device-kind?
- mapped-device-kind-open
- mapped-device-kind-close
- mapped-device-kind-check
- device-mapping-service-type
- device-mapping-service
- luks-device-mapping
- raid-device-mapping))
- (define-record-type* <mapped-device> mapped-device
- make-mapped-device
- mapped-device?
- (source mapped-device-source)
- (target mapped-device-target)
- (type mapped-device-type)
- (location mapped-device-location
- (default (current-source-location)) (innate)))
- (define-record-type* <mapped-device-type> mapped-device-kind
- make-mapped-device-kind
- mapped-device-kind?
- (open mapped-device-kind-open)
- (close mapped-device-kind-close
- (default (const #~(const #f))))
- (check mapped-device-kind-check
- (default (const #t))))
- (define device-mapping-service-type
- (shepherd-service-type
- 'device-mapping
- (match-lambda
- (($ <mapped-device> source target
- ($ <mapped-device-type> open close))
- (shepherd-service
- (provision (list (symbol-append 'device-mapping- (string->symbol target))))
- (requirement '(udev))
- (documentation "Map a device node using Linux's device mapper.")
- (start #~(lambda () #$(open source target)))
- (stop #~(lambda _ (not #$(close source target))))
- (respawn? #f))))))
- (define (device-mapping-service mapped-device)
- "Return a service that sets up @var{mapped-device}."
- (service device-mapping-service-type mapped-device))
- (define (open-luks-device source target)
- "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
- 'cryptsetup'."
- (with-imported-modules (source-module-closure
- '((gnu build file-systems)))
- #~(let ((source #$(if (uuid? source)
- (uuid-bytevector source)
- source)))
-
- (use-modules (rnrs bytevectors)
- ((gnu build file-systems)
- #:select (find-partition-by-luks-uuid)))
-
-
- (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
- "open" "--type" "luks"
-
-
-
-
- (if (bytevector? source)
- (or (let loop ((tries-left 10))
- (and (positive? tries-left)
- (or (find-partition-by-luks-uuid source)
-
-
-
-
-
- (begin (sleep 1)
- (loop (- tries-left 1))))))
- (error "LUKS partition not found" source))
- source)
- #$target)))))
- (define (close-luks-device source target)
- "Return a gexp that closes TARGET, a LUKS device."
- #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
- "close" #$target)))
- (define (check-luks-device md)
- "Ensure the source of MD is valid."
- (let ((source (mapped-device-source md)))
- (or (not (uuid? source))
- (not (zero? (getuid)))
- (find-partition-by-luks-uuid (uuid-bytevector source))
- (raise (condition
- (&message
- (message (format #f (G_ "no LUKS partition with UUID '~a'")
- (uuid->string source))))
- (&error-location
- (location (source-properties->location
- (mapped-device-location md)))))))))
- (define luks-device-mapping
-
- (mapped-device-kind
- (open open-luks-device)
- (close close-luks-device)
- (check check-luks-device)))
- (define (open-raid-device sources target)
- "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
- TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
- #~(let ((sources '#$sources)
-
-
-
- (every (@ (srfi srfi-1) every))
- (format (@ (ice-9 format) format)))
- (let loop ((attempts 0))
- (unless (every file-exists? sources)
- (when (> attempts 20)
- (error "RAID devices did not show up; bailing out"
- sources))
- (format #t "waiting for RAID source devices~{ ~a~}...~%"
- sources)
- (sleep 1)
- (loop (+ 1 attempts))))
-
-
- (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
- "--assemble" #$target sources))))
- (define (close-raid-device sources target)
- "Return a gexp that stops the RAID device TARGET."
- #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
- "--stop" #$target)))
- (define raid-device-mapping
-
- (mapped-device-kind
- (open open-raid-device)
- (close close-raid-device)))
|