summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-12-19 14:26:11 +0100
committerLudovic Courtès <ludo@gnu.org>2014-12-19 17:15:53 +0100
commitc9bf64d6d777baf2603b5d6a52c5c5b9adf649cd (patch)
tree7ec2fb81bebc8d5237df98e7a372fb06ab53985a /guix/build
parentcdae969ae5191d50375c0cb7182d0ac82558875d (diff)
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.
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/syscalls.scm200
1 files changed, 199 insertions, 1 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index e1fafe2266..b210f8faa8 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -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