;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system mapped-devices)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module ((guix modules</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=b4a1252b71ceb3ec0de586154292f753c5de2277'>refs</a><a href='/guix/log/tests'>log</a><a href='/guix/tree/tests?id=b4a1252b71ceb3ec0de586154292f753c5de2277'>tree</a><a href='/guix/commit/tests?id=b4a1252b71ceb3ec0de586154292f753c5de2277'>commit</a><a class='active' href='/guix/diff/tests?id=b4a1252b71ceb3ec0de586154292f753c5de2277&amp;id2=7c16406809d1613cfd3dca306bf88b69bfb64db5'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/tests'>
<input type='hidden' name='id' value='b4a1252b71ceb3ec0de586154292f753c5de2277'/><input type='hidden' name='id2' value='7c16406809d1613cfd3dca306bf88b69bfb64db5'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/diff/?id=b4a1252b71ceb3ec0de586154292f753c5de2277&amp;id2=7c16406809d1613cfd3dca306bf88b69bfb64db5'>root</a>/<a href='/guix/diff/tests?id=b4a1252b71ceb3ec0de586154292f753c5de2277&amp;id2=7c16406809d1613cfd3dca306bf88b69bfb64db5'>tests</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='b4a1252b71ceb3ec0de586154292f753c5de2277'/><input type='hidden' name='id2' value='7c16406809d1613cfd3dca306bf88b69bfb64db5'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><div class='diffstat-header'><a href='/guix/diff/?id=b4a1252b71ceb3ec0de586154292f753c5de2277&amp;id2=7c16406809d1613cfd3dca306bf88b69bfb64db5'>Diffstat</a> (limited to 'tests')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
ervice-type
   'device-mapping
   (match-lambda
     (($ <mapped-device> source targets
                         ($ <mapped-device-type> open close modules))
      (shepherd-service
       (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
       (requirement '(udev))
       (documentation "Map a device node using Linux's device mapper.")
       (start #~(lambda () #$(open source targets)))
       (stop #~(lambda _ (not #$(close source targets))))
       (modules (append %default-modules modules))
       (respawn? #f))))
   (description "Map a device node using Linux's device mapper.")))

(define (device-mapping-service mapped-device)
  "Return a service that sets up @var{mapped-device}."
  (service device-mapping-service-type mapped-device))


;;;
;;; Static checks.
;;;

(define (check-device-initrd-modules device linux-modules location)
  "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
DEVICE must be a \"/dev\" file name."
  (define missing
    ;; Attempt to determine missing modules.
    (catch 'system-error
      (lambda ()
        (missing-modules device linux-modules))

      ;; If we can't do that (e.g., EPERM), skip the whole thing.
      (const '())))

  (unless (null? missing)
    ;; Note: What we suggest here is a list of module names (e.g.,
    ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
    ;; OK because we have machinery that accepts both the hyphen and the
    ;; underscore version.
    (raise (make-compound-condition
            (formatted-message (G_ "you may need these modules \
in the initrd for ~a:~{ ~a~}")
                               device missing)
            (condition
             (&fix-hint
              (hint (format #f (G_ "Try adding them to the
@code{initrd-modules} field of your @code{operating-system} declaration, along
these lines:

@example
 (operating-system
   ;; @dots{}
   (initrd-modules (append (list~{ ~s~})
                           %base-initrd-modules)))
@end example

If you think this diagnostic is inaccurate, use the @option{--skip-checks}
option of @command{guix system}.\n")
                            missing))))
            (condition
             (&error-location
              (location (source-properties->location location))))))))


;;;
;;; Common device mappings.
;;;

(define* (open-luks-device source targets #:key key-file)
  "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'."
  (with-imported-modules (source-module-closure
                          '((gnu build file-systems)
                            (guix build utils))) ;; For mkdir-p
    (match targets
      ((target)
       #~(let ((source #$(if (uuid? source)
                             (uuid-bytevector source)
                             source))
               (keyfile #$key-file))

           ;; Create '/run/cryptsetup/' if it does not exist, as device locking
           ;; is mandatory for LUKS2.
           (mkdir-p "/run/cryptsetup/")

           ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
           ;; whole world inside the initrd (for when we're in an initrd).
           ;; 'cryptsetup open' requires standard input to be a tty to allow
           ;; for interaction but shepherd sets standard input to /dev/null;
           ;; thus, explicitly request a tty.
           (let ((partition
                  ;; Note: We cannot use the "UUID=source" syntax here
                  ;; because 'cryptsetup' implements it by searching the
                  ;; udev-populated /dev/disk/by-id directory but udev may
                  ;; be unavailable at the time we run this.
                  (if (bytevector? source)
                      (or (let loop ((tries-left 10))
                            (and (positive? tries-left)
                                 (or (find-partition-by-luks-uuid source)
                                     ;; If the underlying partition is
                                     ;; not found, try again after
                                     ;; waiting a second, up to ten
                                     ;; times.  FIXME: This should be
                                     ;; dealt with in a more robust way.
                                     (begin (sleep 1)
                                            (loop (- tries-left 1))))))
                          (error "LUKS partition not found" source))
                      source)))
             ;; We want to fallback to the password unlock if the keyfile fails.
             (or (and keyfile
                      (zero? (system*/tty
                              #$(file-append cryptsetup-static "/sbin/cryptsetup")
                              "open" "--type" "luks"
                              "--key-file" keyfile
                              partition #$target)))
                 (zero? (system*/tty
                         #$(file-append cryptsetup-static "/sbin/cryptsetup")
                         "open" "--type" "luks"
                         partition #$target)))))))))

(define (close-luks-device source targets)
  "Return a gexp that closes TARGET, a LUKS device."
  (match targets
    ((target)
     #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
                       "close" #$target)))))

(define* (check-luks-device md #:key
                            needed-for-boot?
                            (initrd-modules '())
                            #:allow-other-keys
                            #:rest rest)
  "Ensure the source of MD is valid."
  (let ((source   (mapped-device-source md))
        (location (mapped-device-location md)))
    (or (not (zero? (getuid)))
        (if (uuid? source)
            (match (find-partition-by-luks-uuid (uuid-bytevector source))
              (#f
               (raise (make-compound-condition
                       (formatted-message (G_ "no LUKS partition with UUID '~a'")
                                          (uuid->string source))
                       (condition
                        (&error-location
                         (location (source-properties->location
                                    (mapped-device-location md))))))))
              ((? string? device)
               (check-device-initrd-modules device initrd-modules location)))
            (check-device-initrd-modules source initrd-modules location)))))

(define luks-device-mapping
  ;; The type of LUKS mapped devices.
  (mapped-device-kind
   (open open-luks-device)
   (close close-luks-device)
   (check check-luks-device)
   (modules '((rnrs bytevectors)                  ;bytevector?
              ((gnu build file-systems)
               #:select (find-partition-by-luks-uuid system*/tty))))))

(define* (luks-device-mapping-with-options #:key key-file)
  "Return a luks-device-mapping object with open modified to pass the arguments
into the open-luks-device procedure."
  (mapped-device-kind
   (inherit luks-device-mapping)
   (open (λ (source targets) (open-luks-device source targets
                                               #:key-file key-file)))))

(define (open-raid-device sources targets)
  "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
  (match targets
    ((target)
     #~(let ((sources '#$sources)

             ;; XXX: We're not at the top level here.  We could use a
             ;; non-top-level 'use-modules' form but that doesn't work when the
             ;; code is eval'd, like the Shepherd does.
             (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))))

         ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
         ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
         (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
                       "--assemble" #$target sources))))))

(define (close-raid-device sources targets)
  "Return a gexp that stops the RAID device TARGET."
  (match targets
    ((target)
     #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
                       "--stop" #$target)))))

(define raid-device-mapping
  ;; The type of RAID mapped devices.
  (mapped-device-kind
   (open open-raid-device)
   (close close-raid-device)))

(define (open-lvm-device source targets)
  #~(and
     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                     "vgchange" "--activate" "ay" #$source))
     ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                     "vgscan" "--mknodes"))
     (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
                              '#$targets))))


(define (close-lvm-device source targets)
  #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                    "vgchange" "--activate" "n" #$source)))

(define lvm-device-mapping
  (mapped-device-kind
   (open open-lvm-device)
   (close close-lvm-device)))

;;; mapped-devices.scm ends here