(address . guix-patches@gnu.org)(name . Danny Milosavljevic)(address . dannym@scratchpost.org)
20190314220823.30769-1-dannym@scratchpost.org
* 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(-)
Toggle diff (168 lines)
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))