diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 156 | ||||
| -rw-r--r-- | guix/utils.scm | 33 | ||||
| -rw-r--r-- | tests/syscalls.scm | 47 |
4 files changed, 207 insertions, 33 deletions
diff --git a/Makefile.am b/Makefile.am index 14e9e4a4b6..20bf650c9b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/svn.scm \ guix/build/vm.scm \ guix/build/activation.scm \ + guix/build/syscalls.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ @@ -143,7 +144,8 @@ SCM_TESTS = \ tests/gexp.scm \ tests/nar.scm \ tests/union.scm \ - tests/profiles.scm + tests/profiles.scm \ + tests/syscalls.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm new file mode 100644 index 0000000000..90cacc760b --- /dev/null +++ b/guix/build/syscalls.scm @@ -0,0 +1,156 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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 match) + #:export (errno + MS_RDONLY + MS_REMOUNT + MS_BIND + MS_MOVE + mount + umount)) + +;;; 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 (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/fstab" read-mtab))) + + (call-with-output-file "/etc/fstab" + (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? #t)) + "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? #t)) + "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)))))) + +;;; syscalls.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 53fc68d27b..700a191d71 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -28,6 +28,7 @@ #:use-module (rnrs bytevectors) #:use-module ((rnrs io ports) #:select (put-bytevector)) #:use-module ((guix build utils) #:select (dump-port)) + #:use-module ((guix build syscalls) #:select (errno)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -366,38 +367,6 @@ that goes to PORT according to COMPRESSION, a symbol such as 'xz." ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu (else #(1 2 3))))) ; *-gnu* -(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 fcntl-flock (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (proc (pointer->procedure int ptr `(,int ,int *)))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm new file mode 100644 index 0000000000..5243ac9a34 --- /dev/null +++ b/tests/syscalls.scm @@ -0,0 +1,47 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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 (test-syscalls) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-64)) + +;; Test the (guix build syscalls) module, although there's not much that can +;; actually be tested without being root. + +(test-begin "syscalls") + +(test-equal "mount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (mount "/dev/null" "/does-not-exist" "ext2") + #f) + (compose system-error-errno list))) + +(test-equal "umount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (umount "/does-not-exist") + #f) + (compose system-error-errno list))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |