M guix/build/syscalls.scm => guix/build/syscalls.scm +199 -1
@@ 42,7 42,11 @@
all-network-interfaces
network-interfaces
network-interface-flags
- loopback-network-interface?))
+ loopback-network-interface?
+ network-interface-address
+ set-network-interface-flags
+ set-network-interface-address
+ configure-network-interface))
;;; Commentary:
;;;
@@ 230,6 234,77 @@ user-land process."
;;;
+;;; Packed structures.
+;;;
+
+(define-syntax sizeof*
+ ;; XXX: This duplicates 'compile-time-value'.
+ (syntax-rules (int128)
+ ((_ int128)
+ 16)
+ ((_ type)
+ (let-syntax ((v (lambda (s)
+ (let ((val (sizeof type)))
+ (syntax-case s ()
+ (_ val))))))
+ v))))
+
+(define-syntax type-size
+ (syntax-rules (~)
+ ((_ (type ~ order))
+ (sizeof* type))
+ ((_ type)
+ (sizeof* type))))
+
+(define-syntax write-type
+ (syntax-rules (~)
+ ((_ bv offset (type ~ order) value)
+ (bytevector-uint-set! bv offset value
+ (endianness order) (sizeof* type)))
+ ((_ bv offset type value)
+ (bytevector-uint-set! bv offset value
+ (native-endianness) (sizeof* type)))))
+
+(define-syntax write-types
+ (syntax-rules ()
+ ((_ bv offset () ())
+ #t)
+ ((_ bv offset (type0 types ...) (field0 fields ...))
+ (begin
+ (write-type bv offset type0 field0)
+ (write-types bv (+ offset (type-size type0))
+ (types ...) (fields ...))))))
+
+(define-syntax read-type
+ (syntax-rules (~)
+ ((_ bv offset (type ~ order))
+ (bytevector-uint-ref bv offset
+ (endianness order) (sizeof* type)))
+ ((_ bv offset type)
+ (bytevector-uint-ref bv offset
+ (native-endianness) (sizeof* type)))))
+
+(define-syntax read-types
+ (syntax-rules ()
+ ((_ bv offset ())
+ '())
+ ((_ bv offset (type0 types ...))
+ (cons (read-type bv offset type0)
+ (read-types bv (+ offset (type-size type0)) (types ...))))))
+
+(define-syntax define-c-struct
+ (syntax-rules ()
+ "Define READ as an optimized serializer and WRITE! as a deserializer for
+the C structure with the given TYPES."
+ ((_ name read write! (fields types) ...)
+ (begin
+ (define (write! bv offset fields ...)
+ (write-types bv offset (types ...) (fields ...)))
+ (define (read bv offset)
+ (read-types bv offset (types ...)))))))
+
+
+;;;
;;; Network interfaces.
;;;
@@ 241,6 316,18 @@ user-land process."
(if (string-contains %host-type "linux")
#x8913 ;GNU/Linux
#xc4804191)) ;GNU/Hurd
+(define SIOCSIFFLAGS
+ (if (string-contains %host-type "linux")
+ #x8914 ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
+(define SIOCGIFADDR
+ (if (string-contains %host-type "linux")
+ #x8915 ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
+(define SIOCSIFADDR
+ (if (string-contains %host-type "linux")
+ #x8916 ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
;; Flags and constants from <net/if.h>.
@@ 263,6 350,56 @@ user-land process."
40
32))
+(define-c-struct sockaddr-in ;<linux/in.h>
+ read-sockaddr-in
+ write-sockaddr-in!
+ (family unsigned-short)
+ (port (int16 ~ big))
+ (address (int32 ~ big)))
+
+(define-c-struct sockaddr-in6 ;<linux/in6.h>
+ read-sockaddr-in6
+ write-sockaddr-in6!
+ (family unsigned-short)
+ (port (int16 ~ big))
+ (flowinfo (int32 ~ big))
+ (address (int128 ~ big))
+ (scopeid int32))
+
+(define (write-socket-address! sockaddr bv index)
+ "Write SOCKADDR, a socket address as returned by 'make-socket-address', to
+bytevector BV at INDEX."
+ (let ((family (sockaddr:fam sockaddr)))
+ (cond ((= family AF_INET)
+ (write-sockaddr-in! bv index
+ family
+ (sockaddr:port sockaddr)
+ (sockaddr:addr sockaddr)))
+ ((= family AF_INET6)
+ (write-sockaddr-in6! bv index
+ family
+ (sockaddr:port sockaddr)
+ (sockaddr:flowinfo sockaddr)
+ (sockaddr:addr sockaddr)
+ (sockaddr:scopeid sockaddr)))
+ (else
+ (error "unsupported socket address" sockaddr)))))
+
+(define (read-socket-address bv index)
+ "Read a socket address from bytevector BV at INDEX."
+ (let ((family (bytevector-u16-native-ref bv index)))
+ (cond ((= family AF_INET)
+ (match (read-sockaddr-in bv index)
+ ((family port address)
+ (make-socket-address family address port))))
+ ((= family AF_INET6)
+ (match (read-sockaddr-in6 bv index)
+ ((family port flowinfo address scopeid)
+ (make-socket-address family address port
+ flowinfo scopeid))))
+ (else
+ "unsupported socket address family" family))))
+
(define %ioctl
;; The most terrible interface, live from Scheme.
(pointer->procedure int
@@ 354,4 491,65 @@ interface NAME."
(close-port sock)
(not (zero? (logand flags IFF_LOOPBACK)))))
+(define (set-network-interface-flags socket name flags)
+ "Set the flag of network interface NAME to FLAGS."
+ (let ((req (make-bytevector ifreq-struct-size)))
+ (bytevector-copy! (string->utf8 name) 0 req 0
+ (min (string-length name) (- IF_NAMESIZE 1)))
+ ;; Set the 'ifr_flags' field.
+ (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
+ (sizeof short))
+ (let* ((ret (%ioctl (fileno socket) SIOCSIFFLAGS
+ (bytevector->pointer req)))
+ (err (errno)))
+ (unless (zero? ret)
+ (throw 'system-error "set-network-interface-flags"
+ "set-network-interface-flags on ~A: ~A"
+ (list name (strerror err))
+ (list err))))))
+
+(define (set-network-interface-address socket name sockaddr)
+ "Set the address of network interface NAME to SOCKADDR."
+ (let ((req (make-bytevector ifreq-struct-size)))
+ (bytevector-copy! (string->utf8 name) 0 req 0
+ (min (string-length name) (- IF_NAMESIZE 1)))
+ ;; Set the 'ifr_addr' field.
+ (write-socket-address! sockaddr req IF_NAMESIZE)
+ (let* ((ret (%ioctl (fileno socket) SIOCSIFADDR
+ (bytevector->pointer req)))
+ (err (errno)))
+ (unless (zero? ret)
+ (throw 'system-error "set-network-interface-address"
+ "set-network-interface-address on ~A: ~A"
+ (list name (strerror err))
+ (list err))))))
+
+(define (network-interface-address socket name)
+ "Return the address of network interface NAME. The result is an object of
+the same type as that returned by 'make-socket-address'."
+ (let ((req (make-bytevector ifreq-struct-size)))
+ (bytevector-copy! (string->utf8 name) 0 req 0
+ (min (string-length name) (- IF_NAMESIZE 1)))
+ (let* ((ret (%ioctl (fileno socket) SIOCGIFADDR
+ (bytevector->pointer req)))
+ (err (errno)))
+ (if (zero? ret)
+ (read-socket-address req IF_NAMESIZE)
+ (throw 'system-error "network-interface-address"
+ "network-interface-address on ~A: ~A"
+ (list name (strerror err))
+ (list err))))))
+
+(define (configure-network-interface name sockaddr flags)
+ "Configure network interface NAME to use SOCKADDR, an address as returned by
+'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants."
+ (let ((sock (socket (sockaddr:fam sockaddr) SOCK_STREAM 0)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (set-network-interface-address sock name sockaddr)
+ (set-network-interface-flags sock name flags))
+ (lambda ()
+ (close-port sock)))))
+
;;; syscalls.scm ends here
M tests/syscalls.scm => tests/syscalls.scm +33 -1
@@ 74,7 74,7 @@
(lset<= string=? names (all-network-interfaces)))))
(test-assert "network-interface-flags"
- (let* ((sock (socket SOCK_STREAM AF_INET 0))
+ (let* ((sock (socket AF_INET SOCK_STREAM 0))
(flags (network-interface-flags sock "lo")))
(close-port sock)
(and (not (zero? (logand flags IFF_LOOPBACK)))
@@ 90,6 90,38 @@
(lambda args
(system-error-errno args)))))
+(test-skip (if (zero? (getuid)) 1 0))
+(test-equal "set-network-interface-flags"
+ EPERM
+ (let ((sock (socket AF_INET SOCK_STREAM 0)))
+ (catch 'system-error
+ (lambda ()
+ (set-network-interface-flags sock "lo" IFF_UP))
+ (lambda args
+ (close-port sock)
+ (system-error-errno args)))))
+
+(test-equal "network-interface-address lo"
+ (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)
+ (let* ((sock (socket AF_INET SOCK_STREAM 0))
+ (addr (network-interface-address sock "lo")))
+ (close-port sock)
+ addr))
+
+(test-equal "set-network-interface-address"
+ EPERM
+ (let ((sock (socket AF_INET SOCK_STREAM 0)))
+ (catch 'system-error
+ (lambda ()
+ (set-network-interface-address sock "nonexistent"
+ (make-socket-address
+ AF_INET
+ (inet-pton AF_INET "127.12.14.15")
+ 0)))
+ (lambda args
+ (close-port sock)
+ (system-error-errno args)))))
+
(test-end)