[bug#34863] [WIP] syscalls: Add loop device interface.

[Danny Milosavljevic]

* guix/build/syscalls.scm (%ioctl-unsigned-long): New procedure.
(LOOP_CTL_GET_FREE): New macro.
(LOOP_SET_FD): New macro.
(LOOP_SET_STATUS64): New macro.
(LOOP_GET_STATUS64): New macro.
(lo-flags): New bits.
(lo-flags->symbols): New procedure.
(LO_NAME_SIZE): New variable.
(LO_KEY_SIZE): New variable.
(%struct-loop-info64): New C structure.
(allocate-new-loop-device): New procedure.
(set-loop-device-backing-file): New procedure.
(get-loop-device-status): New procedure.
* tests/syscalls.scm: Add test.
---
 guix/build/syscalls.scm | 130 +++++++++++++++++++++++++++++++++++++++-
 tests/syscalls.scm      |   4 ++
 2 files changed, 133 insertions(+), 1 deletion(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 66d63a2931..a828aa18e2 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -155,7 +155,12 @@
             utmpx-address
             login-type
             utmpx-entries
-            (read-utmpx-from-port . read-utmpx)))
+            (read-utmpx-from-port . read-utmpx)
+
+            allocate-new-loop-device
+            set-loop-device-backing-file
+            get-loop-device-status
+            set-loop-device-status))
 
 ;;; Commentary:
 ;;;
@@ -1237,6 +1242,10 @@ bytevector BV at INDEX."
   ;; The most terrible interface, live from Scheme.
   (syscall->procedure int "ioctl" (list int unsigned-long '*)))
 
+(define %ioctl-unsigned-long
+  ;; The most terrible interface, live from Scheme.
+  (syscall->procedure int "ioctl" (list int unsigned-long unsigned-long)))
+
 (define (bytes->string bytes)
   "Read BYTES, a list of bytes, and return the null-terminated string decoded
 from there, or #f if that would be an empty string."
@@ -1953,4 +1962,123 @@ entry."
     ((? bytevector? bv)
      (read-utmpx bv))))
 
+;;; Loopback device setup.
+
+;;; /dev/loop-control
+
+(define-syntax LOOP_CTL_GET_FREE       ;<uapi/linux/loop.h>
+  (identifier-syntax #x4C82))
+
+;;; /dev/loopN
+
+(define-syntax LOOP_SET_FD             ;<uapi/linux/loop.h>
+  (identifier-syntax #x4C00))
+
+(define-syntax LOOP_SET_STATUS64       ;<uapi/linux/loop.h>
+  (identifier-syntax #x4C04))
+
+(define-syntax LOOP_GET_STATUS64       ;<uapi/linux/loop.h>
+  (identifier-syntax #x4C05))
+
+(define-bits lo-flags                  ;<uapi/linux/loop.h>
+  lo-flags->symbols
+  (define LO_FLAGS_READ_ONLY 1)
+  (define LO_FLAGS_AUTOCLEAR 4)
+  (define LO_FLAGS_PARTSCAN 8)
+  (define LO_FLAGS_DIRECT_IO 16))
+
+(define LO_NAME_SIZE 64)
+(define LO_KEY_SIZE 32)
+
+;; 'struct loop_info64' for GNU/Linux.   ;<uapi/linux/loop.h>
+(define-c-struct %struct-loop-info64
+  sizeof-loop-info64
+  (lambda (lo-device lo-inode lo-rdevice lo-offset lo-sizelimit lo-number
+           lo-encrypt-type lo-encrypt-key-size lo-flags lo-file-name
+           lo-crypt-name lo-encrypt-key lo-init)
+    `((lo-device . ,lo-device)
+      (lo-inode . ,lo-inode)
+      (lo-rdevice . ,lo-rdevice)
+      (lo-offset . ,lo-offset)
+      (lo-sizelimit . ,lo-sizelimit)
+      (lo-number . ,lo-number)
+      (lo-encrypt-type . ,lo-encrypt-type)
+      (lo-encrypt-key-size . ,lo-encrypt-key-size)
+      (lo-flags . ,(lo-flags->symbols lo-flags))
+      (lo-file-name . ,(bytes->string lo-file-name))
+      (lo-crypt-name . ,(bytes->string lo-crypt-name))
+      (lo-encrypt-key . ,(bytes->string lo-encrypt-key))
+      (lo-init . ,lo-init)))
+  read-loop-info64
+  write-loop-info64!
+  (lo-device uint64) ; ioctl r/o
+  (lo-inode uint64) ; ioctl r/o
+  (lo-rdevice uint64) ; ioctl r/o
+  (lo-offset uint64)
+  (lo-sizelimit uint64) ; Bytes; 0 == max available.
+  (lo-number uint32) ; ioctl r/o
+  (lo-encrypt-type uint32)
+  (lo-encrypt-key-size uint32) ; ioctl w/o
+  (lo-flags uint32)
+  (lo-file-name (array uint8 LO_NAME_SIZE))
+  (lo-crypt-name (array uint8 LO_NAME_SIZE))
+  (lo-encrypt-key (array uint8 LO_KEY_SIZE))
+  (lo-init (array uint64 2)))
+
+(define (allocate-new-loop-device control-file)
+  "Allocates a new loop device and returns an FD for it.
+CONTROL-FILE should be an open file \"/dev/loop-control\".
+The result is a number to be appended to the name \"/dev/loop\" in order to
+find the loop device."
+  (let-values (((ret err)
+                (%ioctl (fileno control-file)
+                        LOOP_CTL_GET_FREE %null-pointer)))
+    (cond
+     ((>= ret 0)
+      (open-io-file (string-append "/dev/loop" (number->string ret))))
+     (else
+      (throw 'system-error "ioctl" "~A"
+             (list (strerror err))
+             (list err))))))
+
+(define (set-loop-device-backing-file loop-file backing-file)
+  "Sets up the loop device LOOP-FILE for BACKING-FILE."
+  (let-values (((ret err)
+                (%ioctl-unsigned-long (fileno loop-file) LOOP_SET_FD
+                                      (fileno backing-file))))
+    (cond
+     ((>= ret 0)
+      #t)
+     (else
+      (throw 'system-error "ioctl" "~A"
+             (list (strerror err))
+             (list err))))))
+
+(define (get-loop-device-status loop-file)
+  (let*-values (((buf) (make-bytevector sizeof-loop-info64))
+                ((ret err)
+                 (%ioctl (fileno loop-file)
+                         LOOP_GET_STATUS64 (bytevector->pointer buf))))
+    (cond
+     ((= ret 0)
+      (read-loop-info64 buf))
+     (else
+      (throw 'system-error "ioctl" "~A"
+             (list (strerror err))
+             (list err))))))
+
+(define (set-loop-device-status loop-file status)
+  (let ((buf (make-bytevector sizeof-loop-info64)))
+    (apply write-loop-info64! buf status) ; TODO: Be more user-friendly.
+    (let-values (((ret err) (%ioctl (fileno loop-file)
+                                    LOOP_SET_STATUS64
+                                    (bytevector->pointer buf))))
+      (cond
+       ((= ret 0)
+        #t)
+       (else
+        (throw 'system-error "ioctl" "~A"
+               (list (strerror err))
+               (list err)))))))
+
 ;;; syscalls.scm ends here
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 3e267c9f01..57b63421b0 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -564,6 +564,10 @@
   (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx)))
     (or (utmpx? result) (eof-object? result))))
 
+(let ((loop-device (allocate-new-loop-device (open-io-file 
"/dev/loop-control"))))
+  (set-loop-device-backing-file loop-device (open-input-file 
"tests/syscalls.scm"))
+  (set-loop-device-status loop-device (get-loop-device-status loop-device)))
+
 (test-end)
 
 (false-if-exception (delete-file temp-file))