futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syscalls: Add more procedures for network interfaces.

Browse Source 
* 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 2014-12-19 14:26:11 +01:00
parent cdae969ae5
commit c9bf64d6d7
2 changed files with 232 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

200
guix/build/syscalls.scm
View File

@ -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

34
tests/syscalls.scm
View File

@ -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)