mirror of git://git.savannah.gnu.org/guix.git
syscalls: Add more procedures for network interfaces.
* guix/build/syscalls.scm (sizeof*, type-size, write-type, write-types, read-type, read-types, define-c-struct): New macros. (SIOCSIFFLAGS, SIOCGIFADDR, SIOCSIFADDR): New variables. (sockaddr-in, sockaddr-in6): New C structs. (write-socket-address!, read-socket-address, set-network-interface-flags, set-network-interface-address, network-interface-address, configure-network-interface): New procedures.
This commit is contained in:
Ludovic Courtès
parent
cdae969ae5
commit
c9bf64d6d7
|
|
@ -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:
|
||||
;;;
|
||||
|
|
@ -228,6 +232,77 @@ user-land process."
|
|||
(scandir "/proc"))
|
||||
<))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue