From a1f708787d08e567da6118bacc481219884296ca Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 25 Apr 2016 17:18:58 +0200
Subject: syscalls: Add 'statfs'.

* guix/build/syscalls.scm (<file-system>): New record type.
(fsword): New macro.
(%statfs): New C struct.
(statfs): New procedure.
---
 guix/build/syscalls.scm | 71 +++++++++++++++++++++++++++++++++++++++++++++++++
 tests/syscalls.scm      | 15 +++++++++++
 2 files changed, 86 insertions(+)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 468dc7eca2..d168293ee4 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -47,6 +47,20 @@
             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
+            statfs
+
             processes
             mkdtemp!
             pivot-root
@@ -457,6 +471,63 @@ 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
+               spare0 spare1 spare2)
+  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)
+  (spare0            file-system--spare0)
+  (spare1            file-system--spare1)
+  (spare2            file-system--spare2))
+
+(define-syntax fsword                             ;fsword_t
+  (identifier-syntax long))
+
+(define-c-struct %statfs
+  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       uint64)                       ;really "int[2]"
+  (name-length      fsword)
+  (fragment-size    fsword)
+  (spare0           int128)                       ;really "fsword[4]"
+  (spare1           int128)
+  (spare2           int64))                     ;XXX: to match array alignment
+
+(define statfs
+  (let ((proc (syscall->procedure int "statfs" '(* *))))
+    (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 0)
+            (throw 'system-error "statfs" "~A: ~A"
+                   (list file (strerror err))
+                   (list err)))))))
+
 
 ;;;
 ;;; Containers.
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 24ea8f5e60..895f90f4d8 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -78,6 +78,21 @@
            (rmdir dir)
            #t))))
 
+(test-equal "statfs, ENOENT"
+  ENOENT
+  (catch 'system-error
+    (lambda ()
+      (statfs "/does-not-exist"))
+    (compose system-error-errno list)))
+
+(test-assert "statfs"
+  (let ((fs (statfs "/")))
+    (and (file-system? fs)
+         (> (file-system-block-size fs) 0)
+         (>= (file-system-blocks-available fs) 0)
+         (>= (file-system-blocks-free fs)
+             (file-system-blocks-available fs)))))
+
 (define (user-namespace pid)
   (string-append "/proc/" (number->string pid) "/ns/user"))
 
-- 
cgit v1.2.3