diff options
Diffstat (limited to 'guix/build/syscalls.scm')
| -rw-r--r-- | guix/build/syscalls.scm | 594 |
1 files changed, 465 insertions, 129 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 69a507def8..4e543d70d8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,6 +47,21 @@ mount-points swapon swapoff + + file-system? + file-system-type + file-system-block-size + file-system-block-count + file-system-blocks-free + file-system-blocks-available + file-system-file-count + file-system-free-file-nodes + file-system-identifier + file-system-maximum-name-length + file-system-fragment-size + file-system-mount-flags + statfs + processes mkdtemp! pivot-root @@ -82,7 +98,31 @@ interface-address interface-netmask interface-broadcast-address - network-interfaces)) + network-interfaces + + termios? + termios-input-flags + termios-output-flags + termios-control-flags + termios-local-flags + termios-line-discipline + termios-control-chars + termios-input-speed + termios-output-speed + local-flags + TCSANOW + TCSADRAIN + TCSAFLUSH + tcgetattr + tcsetattr + + window-size? + window-size-rows + window-size-columns + window-size-x-pixels + window-size-y-pixels + terminal-window-size + terminal-columns)) ;;; Commentary: ;;; @@ -92,6 +132,155 @@ ;;; ;;; Code: + +;;; +;;; Packed structures. +;;; + +(define-syntax sizeof* + ;; XXX: This duplicates 'compile-time-value'. + (syntax-rules (int128 array) + ((_ int128) + 16) + ((_ (array type n)) + (* (sizeof* type) n)) + ((_ type) + (let-syntax ((v (lambda (s) + (let ((val (sizeof type))) + (syntax-case s () + (_ val)))))) + v)))) + +(define-syntax alignof* + ;; XXX: This duplicates 'compile-time-value'. + (syntax-rules (int128 array) + ((_ int128) + 16) + ((_ (array type n)) + (alignof* type)) + ((_ type) + (let-syntax ((v (lambda (s) + (let ((val (alignof type))) + (syntax-case s () + (_ val)))))) + v)))) + +(define-syntax align ;as found in (system foreign) + (syntax-rules (~) + "Add to OFFSET whatever it takes to get proper alignment for TYPE." + ((_ offset (type ~ endianness)) + (align offset type)) + ((_ offset type) + (1+ (logior (1- offset) (1- (alignof* type))))))) + +(define-syntax type-size + (syntax-rules (~) + ((_ (type ~ order)) + (sizeof* type)) + ((_ type) + (sizeof* type)))) + +(define-syntax struct-alignment + (syntax-rules () + "Compute the alignment for the aggregate made of TYPES at OFFSET. The +result is the alignment of the \"most strictly aligned component\"." + ((_ offset types ...) + (max (align offset types) ...)))) + +(define-syntax struct-size + (syntax-rules () + "Return the size in bytes of the structure made of TYPES." + ((_ offset (types-processed ...)) + ;; The SysV ABI P.S. says: "Aggregates (structures and arrays) and unions + ;; assume the alignment of their most strictly aligned component." As an + ;; example, a struct such as "int32, int16" has size 8, not 6. + (1+ (logior (1- offset) + (1- (struct-alignment offset types-processed ...))))) + ((_ offset (types-processed ...) type0 types ...) + (struct-size (+ (type-size type0) (align offset type0)) + (type0 types-processed ...) + types ...)))) + +(define-syntax write-type + (syntax-rules (~ array) + ((_ bv offset (type ~ order) value) + (bytevector-uint-set! bv offset value + (endianness order) (sizeof* type))) + ((_ bv offset (array type n) value) + (let loop ((i 0) + (value value) + (o offset)) + (unless (= i n) + (match value + ((head . tail) + (write-type bv o type head) + (loop (+ 1 i) tail (+ o (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 (align offset type0) type0 field0) + (write-types bv + (+ (align offset type0) (type-size type0)) + (types ...) (fields ...)))))) + +(define-syntax read-type + (syntax-rules (~ array quote *) + ((_ bv offset '*) + (make-pointer (bytevector-uint-ref bv offset + (native-endianness) + (sizeof* '*)))) + ((_ bv offset (type ~ order)) + (bytevector-uint-ref bv offset + (endianness order) (sizeof* type))) + ((_ bv offset (array type n)) + (unfold (lambda (i) (= i n)) + (lambda (i) + (read-type bv (+ offset (* i (sizeof* type))) type)) + 1+ + 0)) + ((_ bv offset type) + (bytevector-uint-ref bv offset + (native-endianness) (sizeof* type))))) + +(define-syntax read-types + (syntax-rules () + ((_ return bv offset () (values ...)) + (return values ...)) + ((_ return bv offset (type0 types ...) (values ...)) + (read-types return + bv + (+ (align offset type0) (type-size type0)) + (types ...) + (values ... (read-type bv + (align offset type0) + type0)))))) + +(define-syntax define-c-struct + (syntax-rules () + "Define SIZE as the size in bytes of the C structure made of FIELDS. READ +as a deserializer and WRITE! as a serializer for the C structure with the +given TYPES. READ uses WRAP-FIELDS to return its value." + ((_ name size wrap-fields read write! (fields types) ...) + (begin + (define size + (struct-size 0 () types ...)) + (define (write! bv offset fields ...) + (write-types bv offset (types ...) (fields ...))) + (define* (read bv #:optional (offset 0)) + (read-types wrap-fields bv offset (types ...) ())))))) + + +;;; +;;; FFI. +;;; + (define %libc-errno-pointer ;; Glibc's 'errno' pointer. (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) @@ -137,6 +326,24 @@ "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." (call-with-restart-on-EINTR (lambda () expr))) +(define (syscall->procedure return-type name argument-types) + "Return a procedure that wraps the C function NAME using the dynamic FFI. +If an error occurs while creating the binding, defer the error report until +the returned procedure is called." + (catch #t + (lambda () + (let ((ptr (dynamic-func name (dynamic-link)))) + (pointer->procedure return-type ptr argument-types))) + (lambda args + (lambda _ + (error (format #f "~a: syscall->procedure failed: ~s" + name args)))))) + + +;;; +;;; File systems. +;;; + (define (augment-mtab source target type options) "Augment /etc/mtab with information about the given mount point." (let ((port (open-file "/etc/mtab" "a"))) @@ -185,8 +392,7 @@ (define UMOUNT_NOFOLLOW 8) (define mount - (let* ((ptr (dynamic-func "mount" (dynamic-link))) - (proc (pointer->procedure int ptr `(* * * ,unsigned-long *)))) + (let ((proc (syscall->procedure int "mount" `(* * * ,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 @@ -214,8 +420,7 @@ error." (augment-mtab source target type options)))))) (define umount - (let* ((ptr (dynamic-func "umount2" (dynamic-link))) - (proc (pointer->procedure int ptr `(* ,int)))) + (let ((proc (syscall->procedure int "umount2" `(* ,int)))) (lambda* (target #:optional (flags 0) #:key (update-mtab? #f)) "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* @@ -242,8 +447,7 @@ constants from <sys/mount.h>." (loop (cons mount-point result)))))))))) (define swapon - (let* ((ptr (dynamic-func "swapon" (dynamic-link))) - (proc (pointer->procedure int ptr (list '* int)))) + (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) "Use the block special device at DEVICE for swapping." (let ((ret (proc (string->pointer device) flags)) @@ -254,8 +458,7 @@ constants from <sys/mount.h>." (list err))))))) (define swapoff - (let* ((ptr (dynamic-func "swapoff" (dynamic-link))) - (proc (pointer->procedure int ptr '(*)))) + (let ((proc (syscall->procedure int "swapoff" '(*)))) (lambda (device) "Stop using block special device DEVICE for swapping." (let ((ret (proc (string->pointer device))) @@ -304,6 +507,65 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (list err))) (pointer->string result))))) + +(define-record-type <file-system> + (file-system type block-size blocks blocks-free + blocks-available files free-files identifier + name-length fragment-size mount-flags spare) + file-system? + (type file-system-type) + (block-size file-system-block-size) + (blocks file-system-block-count) + (blocks-free file-system-blocks-free) + (blocks-available file-system-blocks-available) + (files file-system-file-count) + (free-files file-system-free-file-nodes) + (identifier file-system-identifier) + (name-length file-system-maximum-name-length) + (fragment-size file-system-fragment-size) + (mount-flags file-system-mount-flags) + (spare file-system--spare)) + +(define-syntax fsword ;fsword_t + (identifier-syntax long)) + +(define-c-struct %statfs ;<bits/statfs.h> + sizeof-statfs ;slightly overestimated + file-system + read-statfs + write-statfs! + (type fsword) + (block-size fsword) + (blocks uint64) + (blocks-free uint64) + (blocks-available uint64) + (files uint64) + (free-files uint64) + (identifier (array int 2)) + (name-length fsword) + (fragment-size fsword) + (mount-flags fsword) + (spare (array fsword 4))) + +(define statfs + (let ((proc (syscall->procedure int "statfs64" '(* *)))) + (lambda (file) + "Return a <file-system> data structure describing the file system +mounted at FILE." + (let* ((stat (make-bytevector sizeof-statfs)) + (ret (proc (string->pointer file) (bytevector->pointer stat))) + (err (errno))) + (if (zero? ret) + (read-statfs stat) + (throw 'system-error "statfs" "~A: ~A" + (list file (strerror err)) + (list err))))))) + + +;;; +;;; Containers. +;;; + ;; Linux clone flags, from linux/sched.h (define CLONE_CHILD_CLEARTID #x00200000) (define CLONE_CHILD_SETTID #x01000000) @@ -319,18 +581,18 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." ;; declared in <unistd.h> as a variadic function; in practice, it expects 6 ;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S. (define clone - (let* ((ptr (dynamic-func "syscall" (dynamic-link))) - (proc (pointer->procedure long ptr - (list long ;sysno - unsigned-long ;flags - '* '* '* - '*))) + (let* ((proc (syscall->procedure int "syscall" + (list long ;sysno + unsigned-long ;flags + '* '* '* + '*))) ;; TODO: Don't do this. (syscall-id (match (utsname:machine (uname)) ("i686" 120) ("x86_64" 56) ("mips64" 5055) - ("armv7l" 120)))) + ("armv7l" 120) + (_ #f)))) (lambda (flags) "Create a new child process by duplicating the current parent process. Unlike the fork system call, clone accepts FLAGS that specify which resources @@ -365,8 +627,7 @@ there is no such limitation." (list err)))))))) (define pivot-root - (let* ((ptr (dynamic-func "pivot_root" (dynamic-link))) - (proc (pointer->procedure int ptr (list '* '*)))) + (let ((proc (syscall->procedure int "pivot_root" (list '* '*)))) (lambda (new-root put-old) "Change the root file system to NEW-ROOT and move the current root file system to PUT-OLD." @@ -380,107 +641,6 @@ system to PUT-OLD." ;;; -;;; 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 alignof* - ;; XXX: This duplicates 'compile-time-value'. - (syntax-rules (int128) - ((_ int128) - 16) - ((_ type) - (let-syntax ((v (lambda (s) - (let ((val (alignof type))) - (syntax-case s () - (_ val)))))) - v)))) - -(define-syntax align ;as found in (system foreign) - (syntax-rules (~) - "Add to OFFSET whatever it takes to get proper alignment for TYPE." - ((_ offset (type ~ endianness)) - (align offset type)) - ((_ offset type) - (1+ (logior (1- offset) (1- (alignof* type))))))) - -(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 (align offset type0) type0 field0) - (write-types bv - (+ (align offset type0) (type-size type0)) - (types ...) (fields ...)))))) - -(define-syntax read-type - (syntax-rules (~ quote *) - ((_ bv offset '*) - (make-pointer (bytevector-uint-ref bv offset - (native-endianness) - (sizeof* '*)))) - ((_ 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 () - ((_ return bv offset () (values ...)) - (return values ...)) - ((_ return bv offset (type0 types ...) (values ...)) - (read-types return - bv - (+ (align offset type0) (type-size type0)) - (types ...) - (values ... (read-type bv - (align offset type0) - type0)))))) - -(define-syntax define-c-struct - (syntax-rules () - "Define READ as a deserializer and WRITE! as a serializer for the C -structure with the given TYPES. READ uses WRAP-FIELDS to return its value." - ((_ name wrap-fields read write! (fields types) ...) - (begin - (define (write! bv offset fields ...) - (write-types bv offset (types ...) (fields ...))) - (define (read bv offset) - (read-types wrap-fields bv offset (types ...) ())))))) - - -;;; ;;; Network interfaces. ;;; @@ -527,6 +687,7 @@ structure with the given TYPES. READ uses WRAP-FIELDS to return its value." 32)) (define-c-struct sockaddr-in ;<linux/in.h> + sizeof-sockaddrin (lambda (family port address) (make-socket-address family address port)) read-sockaddr-in @@ -536,6 +697,7 @@ structure with the given TYPES. READ uses WRAP-FIELDS to return its value." (address (int32 ~ big))) (define-c-struct sockaddr-in6 ;<linux/in6.h> + sizeof-sockaddr-in6 (lambda (family port flowinfo address scopeid) (make-socket-address family address port flowinfo scopeid)) read-sockaddr-in6 @@ -800,6 +962,7 @@ an <interface> object, and whose cdr is the pointer NEXT." next)) (define-c-struct ifaddrs ;<ifaddrs.h> + %sizeof-ifaddrs values->interface read-ifaddrs write-ifaddrs! @@ -811,14 +974,6 @@ an <interface> object, and whose cdr is the pointer NEXT." (broadcastaddr '*) (data '*)) -(define-syntax %struct-ifaddrs-type - (identifier-syntax - `(* * ,unsigned-int * * * *))) - -(define-syntax %sizeof-ifaddrs - (identifier-syntax - (sizeof* %struct-ifaddrs-type))) - (define (unfold-interface-list ptr) "Call 'read-ifaddrs' on PTR and all its 'next' fields, recursively, and return the list of resulting <interface> objects." @@ -826,8 +981,7 @@ return the list of resulting <interface> objects." (result '())) (if (null-pointer? ptr) (reverse result) - (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs) - 0) + (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs)) ((ifaddr . ptr) (loop ptr (cons ifaddr result))))))) @@ -853,4 +1007,186 @@ network interface. This is implemented using the 'getifaddrs' libc function." (let ((ptr (dynamic-func "freeifaddrs" (dynamic-link)))) (pointer->procedure void ptr '(*)))) + +;;; +;;; Terminals. +;;; + +(define-syntax bits->symbols-body + (syntax-rules () + ((_ bits () ()) + '()) + ((_ bits (name names ...) (value values ...)) + (let ((result (bits->symbols-body bits (names ...) (values ...)))) + (if (zero? (logand bits value)) + result + (cons 'name result)))))) + +(define-syntax define-bits + (syntax-rules (define) + "Define the given numerical constants under CONSTRUCTOR, such that + (CONSTRUCTOR NAME) returns VALUE. Define BITS->SYMBOLS as a procedure that, +given an integer, returns the list of names of the constants that are or'd." + ((_ constructor bits->symbols (define names values) ...) + (begin + (define-syntax constructor + (syntax-rules (names ...) + ((_ names) values) ... + ((_ several (... ...)) + (logior (constructor several) (... ...))))) + (define (bits->symbols bits) + (bits->symbols-body bits (names ...) (values ...))) + (define names values) ...)))) + +;; 'local-flags' bits from <bits/termios.h> +(define-bits local-flags + local-flags->symbols + (define ISIG #o0000001) + (define ICANON #o0000002) + (define XCASE #o0000004) + (define ECHO #o0000010) + (define ECHOE #o0000020) + (define ECHOK #o0000040) + (define ECHONL #o0000100) + (define NOFLSH #o0000200) + (define TOSTOP #o0000400) + (define ECHOCTL #o0001000) + (define ECHOPRT #o0002000) + (define ECHOKE #o0004000) + (define FLUSHO #o0010000) + (define PENDIN #o0040000) + (define IEXTEN #o0100000) + (define EXTPROC #o0200000)) + +;; "Actions" values for 'tcsetattr'. +(define TCSANOW 0) +(define TCSADRAIN 1) +(define TCSAFLUSH 2) + +(define-record-type <termios> + (termios input-flags output-flags control-flags local-flags + line-discipline control-chars + input-speed output-speed) + termios? + (input-flags termios-input-flags) + (output-flags termios-output-flags) + (control-flags termios-control-flags) + (local-flags termios-local-flags) + (line-discipline termios-line-discipline) + (control-chars termios-control-chars) + (input-speed termios-input-speed) + (output-speed termios-output-speed)) + +(define-c-struct %termios ;<bits/termios.h> + sizeof-termios + termios + read-termios + write-termios! + (input-flags unsigned-int) + (output-flags unsigned-int) + (control-flags unsigned-int) + (local-flags unsigned-int) + (line-discipline uint8) + (control-chars (array uint8 32)) + (input-speed unsigned-int) + (output-speed unsigned-int)) + +(define tcgetattr + (let ((proc (syscall->procedure int "tcgetattr" (list int '*)))) + (lambda (fd) + "Return the <termios> structure for the tty at FD." + (let* ((bv (make-bytevector sizeof-termios)) + (ret (proc fd (bytevector->pointer bv))) + (err (errno))) + (if (zero? ret) + (read-termios bv) + (throw 'system-error "tcgetattr" "~A" + (list (strerror err)) + (list err))))))) + +(define tcsetattr + (let ((proc (syscall->procedure int "tcsetattr" (list int int '*)))) + (lambda (fd actions termios) + "Use TERMIOS for the tty at FD. ACTIONS is one of 'TCSANOW', +'TCSADRAIN', or 'TCSAFLUSH'; see tcsetattr(3) for details." + (define bv + (make-bytevector sizeof-termios)) + + (let-syntax ((match/write (syntax-rules () + ((_ fields ...) + (match termios + (($ <termios> fields ...) + (write-termios! bv 0 fields ...))))))) + (match/write input-flags output-flags control-flags local-flags + line-discipline control-chars input-speed output-speed)) + + (let ((ret (proc fd actions (bytevector->pointer bv))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "tcgetattr" "~A" + (list (strerror err)) + (list err))))))) + +(define-syntax TIOCGWINSZ ;<asm-generic/ioctls.h> + (identifier-syntax #x5413)) + +(define-record-type <window-size> + (window-size rows columns x-pixels y-pixels) + window-size? + (rows window-size-rows) + (columns window-size-columns) + (x-pixels window-size-x-pixels) + (y-pixels window-size-y-pixels)) + +(define-c-struct winsize ;<bits/ioctl-types.h> + sizeof-winsize + window-size + read-winsize + write-winsize! + (rows unsigned-short) + (columns unsigned-short) + (x-pixels unsigned-short) + (y-pixels unsigned-short)) + +(define* (terminal-window-size #:optional (port (current-output-port))) + "Return a <window-size> structure describing the terminal at PORT, or raise +a 'system-error' if PORT is not backed by a terminal. This procedure +corresponds to the TIOCGWINSZ ioctl." + (let* ((size (make-bytevector sizeof-winsize)) + (ret (%ioctl (fileno port) TIOCGWINSZ + (bytevector->pointer size))) + (err (errno))) + (if (zero? ret) + (read-winsize size) + (throw 'system-error "terminal-window-size" "~A" + (list (strerror err)) + (list err))))) + +(define* (terminal-columns #:optional (port (current-output-port))) + "Return the best approximation of the number of columns of the terminal at +PORT, trying to guess a reasonable value if all else fails. The result is +always a positive integer." + (define (fall-back) + (match (and=> (getenv "COLUMNS") string->number) + (#f 80) + ((? number? columns) + (if (> columns 0) columns 80)))) + + (catch 'system-error + (lambda () + (if (file-port? port) + (match (window-size-columns (terminal-window-size port)) + ;; Things like Emacs shell-mode return 0, which is unreasonable. + (0 (fall-back)) + ((? number? columns) columns)) + (fall-back))) + (lambda args + (let ((errno (system-error-errno args))) + ;; ENOTTY is what we're after but 2012-and-earlier Linux versions + ;; would return EINVAL instead in some cases: + ;; <https://bugs.ruby-lang.org/issues/10494>. + (if (or (= errno ENOTTY) (= errno EINVAL)) + (fall-back) + (apply throw args)))))) + ;;; syscalls.scm ends here |