584 lines
22 KiB
Scheme
584 lines
22 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix build syscalls)
|
||
#:use-module (system foreign)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (ice-9 rdelim)
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 ftw)
|
||
#:export (errno
|
||
MS_RDONLY
|
||
MS_REMOUNT
|
||
MS_BIND
|
||
MS_MOVE
|
||
restart-on-EINTR
|
||
mount
|
||
umount
|
||
mount-points
|
||
swapon
|
||
swapoff
|
||
processes
|
||
|
||
IFF_UP
|
||
IFF_BROADCAST
|
||
IFF_LOOPBACK
|
||
all-network-interfaces
|
||
network-interfaces
|
||
network-interface-flags
|
||
loopback-network-interface?
|
||
network-interface-address
|
||
set-network-interface-flags
|
||
set-network-interface-address
|
||
set-network-interface-up
|
||
configure-network-interface))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides bindings to libc's syscall wrappers. It uses the
|
||
;;; FFI, and thus requires a dynamically-linked Guile. (For statically-linked
|
||
;;; Guile, we instead apply 'guile-linux-syscalls.patch'.)
|
||
;;;
|
||
;;; Code:
|
||
|
||
(define %libc-errno-pointer
|
||
;; Glibc's 'errno' pointer.
|
||
(let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
|
||
(and errno-loc
|
||
(let ((proc (pointer->procedure '* errno-loc '())))
|
||
(proc)))))
|
||
|
||
(define errno
|
||
(if %libc-errno-pointer
|
||
(let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
|
||
(lambda ()
|
||
"Return the current errno."
|
||
;; XXX: We assume that nothing changes 'errno' while we're doing all this.
|
||
;; In particular, that means that no async must be running here.
|
||
|
||
;; Use one of the fixed-size native-ref procedures because they are
|
||
;; optimized down to a single VM instruction, which reduces the risk
|
||
;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
|
||
(let-syntax ((ref (lambda (s)
|
||
(syntax-case s ()
|
||
((_ bv)
|
||
(case (sizeof int)
|
||
((4)
|
||
#'(bytevector-s32-native-ref bv 0))
|
||
((8)
|
||
#'(bytevector-s64-native-ref bv 0))
|
||
(else
|
||
(error "unsupported 'int' size"
|
||
(sizeof int)))))))))
|
||
(ref bv))))
|
||
(lambda () 0)))
|
||
|
||
(define (call-with-restart-on-EINTR thunk)
|
||
(let loop ()
|
||
(catch 'system-error
|
||
thunk
|
||
(lambda args
|
||
(if (= (system-error-errno args) EINTR)
|
||
(loop)
|
||
(apply throw args))))))
|
||
|
||
(define-syntax-rule (restart-on-EINTR expr)
|
||
"Evaluate EXPR and restart upon EINTR. Return the value of EXPR."
|
||
(call-with-restart-on-EINTR (lambda () expr)))
|
||
|
||
(define (augment-mtab source target type options)
|
||
"Augment /etc/mtab with information about the given mount point."
|
||
(let ((port (open-file "/etc/mtab" "a")))
|
||
(format port "~a ~a ~a ~a 0 0~%"
|
||
source target type (or options "rw"))
|
||
(close-port port)))
|
||
|
||
(define (read-mtab port)
|
||
"Read an mtab-formatted file from PORT, returning a list of tuples."
|
||
(let loop ((result '()))
|
||
(let ((line (read-line port)))
|
||
(if (eof-object? line)
|
||
(reverse result)
|
||
(loop (cons (string-tokenize line) result))))))
|
||
|
||
(define (remove-from-mtab target)
|
||
"Remove mount point TARGET from /etc/mtab."
|
||
(define entries
|
||
(remove (match-lambda
|
||
((device mount-point type options freq passno)
|
||
(string=? target mount-point))
|
||
(_ #f))
|
||
(call-with-input-file "/etc/mtab" read-mtab)))
|
||
|
||
(call-with-output-file "/etc/mtab"
|
||
(lambda (port)
|
||
(for-each (match-lambda
|
||
((device mount-point type options freq passno)
|
||
(format port "~a ~a ~a ~a ~a ~a~%"
|
||
device mount-point type options freq passno)))
|
||
entries))))
|
||
|
||
;; Linux mount flags, from libc's <sys/mount.h>.
|
||
(define MS_RDONLY 1)
|
||
(define MS_REMOUNT 32)
|
||
(define MS_BIND 4096)
|
||
(define MS_MOVE 8192)
|
||
|
||
(define mount
|
||
(let* ((ptr (dynamic-func "mount" (dynamic-link)))
|
||
(proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
|
||
(lambda* (source target type #:optional (flags 0) options
|
||
#:key (update-mtab? #f))
|
||
"Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS
|
||
may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
|
||
string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When
|
||
UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on
|
||
error."
|
||
(let ((ret (proc (if source
|
||
(string->pointer source)
|
||
%null-pointer)
|
||
(string->pointer target)
|
||
(if type
|
||
(string->pointer type)
|
||
%null-pointer)
|
||
flags
|
||
(if options
|
||
(string->pointer options)
|
||
%null-pointer)))
|
||
(err (errno)))
|
||
(unless (zero? ret)
|
||
(throw 'system-error "mount" "mount ~S on ~S: ~A"
|
||
(list source target (strerror err))
|
||
(list err)))
|
||
(when update-mtab?
|
||
(augment-mtab source target type options))))))
|
||
|
||
(define umount
|
||
(let* ((ptr (dynamic-func "umount2" (dynamic-link)))
|
||
(proc (pointer->procedure int ptr `(* ,int))))
|
||
(lambda* (target #:optional (flags 0)
|
||
#:key (update-mtab? #f))
|
||
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
|
||
constants from <sys/mount.h>."
|
||
(let ((ret (proc (string->pointer target) flags))
|
||
(err (errno)))
|
||
(unless (zero? ret)
|
||
(throw 'system-error "umount" "~S: ~A"
|
||
(list target (strerror err))
|
||
(list err)))
|
||
(when update-mtab?
|
||
(remove-from-mtab target))))))
|
||
|
||
(define (mount-points)
|
||
"Return the mounts points for currently mounted file systems."
|
||
(call-with-input-file "/proc/mounts"
|
||
(lambda (port)
|
||
(let loop ((result '()))
|
||
(let ((line (read-line port)))
|
||
(if (eof-object? line)
|
||
(reverse result)
|
||
(match (string-tokenize line)
|
||
((source mount-point _ ...)
|
||
(loop (cons mount-point result))))))))))
|
||
|
||
(define swapon
|
||
(let* ((ptr (dynamic-func "swapon" (dynamic-link)))
|
||
(proc (pointer->procedure int ptr (list '* int))))
|
||
(lambda* (device #:optional (flags 0))
|
||
"Use the block special device at DEVICE for swapping."
|
||
(let ((ret (proc (string->pointer device) flags))
|
||
(err (errno)))
|
||
(unless (zero? ret)
|
||
(throw 'system-error "swapon" "~S: ~A"
|
||
(list device (strerror err))
|
||
(list err)))))))
|
||
|
||
(define swapoff
|
||
(let* ((ptr (dynamic-func "swapoff" (dynamic-link)))
|
||
(proc (pointer->procedure int ptr '(*))))
|
||
(lambda (device)
|
||
"Stop using block special device DEVICE for swapping."
|
||
(let ((ret (proc (string->pointer device)))
|
||
(err (errno)))
|
||
(unless (zero? ret)
|
||
(throw 'system-error "swapoff" "~S: ~A"
|
||
(list device (strerror err))
|
||
(list err)))))))
|
||
|
||
(define (kernel? pid)
|
||
"Return #t if PID designates a \"kernel thread\" rather than a normal
|
||
user-land process."
|
||
(let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid)
|
||
(compose string-tokenize read-string))))
|
||
;; See proc.txt in Linux's documentation for the list of fields.
|
||
(match stat
|
||
((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt
|
||
cmin_flt maj_flt cmaj_flt utime stime cutime cstime
|
||
priority nice num_thread it_real_value start_time
|
||
vsize rss rsslim
|
||
(= string->number start_code) (= string->number end_code) _ ...)
|
||
;; Got this obscure trick from sysvinit's 'killall5' program.
|
||
(and (zero? start_code) (zero? end_code))))))
|
||
|
||
(define (processes)
|
||
"Return the list of live processes."
|
||
(sort (filter-map (lambda (file)
|
||
(let ((pid (string->number file)))
|
||
(and pid
|
||
(not (kernel? pid))
|
||
pid)))
|
||
(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.
|
||
;;;
|
||
|
||
(define SIOCGIFCONF ;from <bits/ioctls.h>
|
||
(if (string-contains %host-type "linux")
|
||
#x8912 ;GNU/Linux
|
||
#xf00801a4)) ;GNU/Hurd
|
||
(define SIOCGIFFLAGS
|
||
(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>.
|
||
|
||
(define IFF_UP #x1) ;Interface is up
|
||
(define IFF_BROADCAST #x2) ;Broadcast address valid.
|
||
(define IFF_LOOPBACK #x8) ;Is a loopback net.
|
||
|
||
(define IF_NAMESIZE 16) ;maximum interface name size
|
||
|
||
(define ifconf-struct
|
||
;; 'struct ifconf', from <net/if.h>.
|
||
(list int ;int ifc_len
|
||
'*)) ;struct ifreq *ifc_ifcu
|
||
|
||
(define ifreq-struct-size
|
||
;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the
|
||
;; interface name (nul-terminated), followed by a bunch of stuff. This is
|
||
;; its size in bytes.
|
||
(if (= 8 (sizeof '*))
|
||
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
|
||
(dynamic-func "ioctl" (dynamic-link))
|
||
(list int unsigned-long '*)))
|
||
|
||
(define (bytevector->string-list bv stride len)
|
||
"Return the null-terminated strings found in BV every STRIDE bytes. Read at
|
||
most LEN bytes from BV."
|
||
(let loop ((bytes (take (bytevector->u8-list bv)
|
||
(min len (bytevector-length bv))))
|
||
(result '()))
|
||
(match bytes
|
||
(()
|
||
(reverse result))
|
||
(_
|
||
(loop (drop bytes stride)
|
||
(cons (list->string (map integer->char
|
||
(take-while (negate zero?) bytes)))
|
||
result))))))
|
||
|
||
(define* (network-interfaces #:optional sock)
|
||
"Return the list of existing network interfaces. This is typically limited
|
||
to interfaces that are currently up."
|
||
(let* ((close? (not sock))
|
||
(sock (or sock (socket SOCK_STREAM AF_INET 0)))
|
||
(len (* ifreq-struct-size 10))
|
||
(reqs (make-bytevector len))
|
||
(conf (make-c-struct ifconf-struct
|
||
(list len (bytevector->pointer reqs))))
|
||
(ret (%ioctl (fileno sock) SIOCGIFCONF conf))
|
||
(err (errno)))
|
||
(when close?
|
||
(close-port sock))
|
||
(if (zero? ret)
|
||
(bytevector->string-list reqs ifreq-struct-size
|
||
(match (parse-c-struct conf ifconf-struct)
|
||
((len . _) len)))
|
||
(throw 'system-error "network-interface-list"
|
||
"network-interface-list: ~A"
|
||
(list (strerror err))
|
||
(list err)))))
|
||
|
||
(define %interface-line
|
||
;; Regexp matching an interface line in Linux's /proc/net/dev.
|
||
(make-regexp "^[[:blank:]]*([[:alnum:]]+):.*$"))
|
||
|
||
(define (all-network-interfaces)
|
||
"Return all the registered network interfaces, including those that are not
|
||
up."
|
||
(call-with-input-file "/proc/net/dev" ;XXX: Linux-specific
|
||
(lambda (port)
|
||
(let loop ((interfaces '()))
|
||
(let ((line (read-line port)))
|
||
(cond ((eof-object? line)
|
||
(reverse interfaces))
|
||
((regexp-exec %interface-line line)
|
||
=>
|
||
(lambda (match)
|
||
(loop (cons (match:substring match 1) interfaces))))
|
||
(else
|
||
(loop interfaces))))))))
|
||
|
||
(define (network-interface-flags socket name)
|
||
"Return a number that is the bit-wise or of 'IFF*' flags for network
|
||
interface NAME."
|
||
(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) SIOCGIFFLAGS
|
||
(bytevector->pointer req)))
|
||
(err (errno)))
|
||
(if (zero? ret)
|
||
|
||
;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of
|
||
;; 'struct ifreq', and it's a short int.
|
||
(bytevector-sint-ref req IF_NAMESIZE (native-endianness)
|
||
(sizeof short))
|
||
|
||
(throw 'system-error "network-interface-flags"
|
||
"network-interface-flags on ~A: ~A"
|
||
(list name (strerror err))
|
||
(list err))))))
|
||
|
||
(define (loopback-network-interface? name)
|
||
"Return true if NAME designates a loopback network interface."
|
||
(let* ((sock (socket SOCK_STREAM AF_INET 0))
|
||
(flags (network-interface-flags sock 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)))))
|
||
|
||
(define* (set-network-interface-up name
|
||
#:key (family AF_INET))
|
||
"Turn up the interface NAME."
|
||
(let ((sock (socket family SOCK_STREAM 0)))
|
||
(dynamic-wind
|
||
(const #t)
|
||
(lambda ()
|
||
(let ((flags (network-interface-flags sock name)))
|
||
(set-network-interface-flags sock name
|
||
(logior flags IFF_UP))))
|
||
(lambda ()
|
||
(close-port sock)))))
|
||
|
||
;;; syscalls.scm ends here
|