4 files changed, 207 insertions(+), 33 deletions(-)

M Makefile.am
A guix/build/syscalls.scm
M guix/utils.scm
A tests/syscalls.scm

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

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

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

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