syscalls: Add utmpx procedures and data structure.

* guix/build/syscalls.scm (<utmpx-entry>): New record type.
(%utmpx): New C struct.
(login-type): New bits.
(setutxent, endutxent, getutxent, utmpx-entries): New procedures.

2 files changed, 124 insertions, 2 deletions

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index c06013cd08..475fc96490 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -126,7 +127,22 @@
             window-size-x-pixels
             window-size-y-pixels
             terminal-window-size
-            terminal-columns))
+            terminal-columns
+
+            utmpx?
+            utmpx-login-type
+            utmpx-pid
+            utmpx-line
+            utmpx-id
+            utmpx-user
+            utmpx-host
+            utmpx-termination-status
+            utmpx-exit-status
+            utmpx-session-id
+            utmpx-time
+            utmpx-address
+            login-type
+            utmpx-entries))
 
 ;;; Commentary:
 ;;;
@@ -1487,4 +1503,99 @@ always a positive integer."
             (fall-back)
             (apply throw args))))))
 
+
+;;;
+;;; utmpx.
+;;;
+
+(define-record-type <utmpx-entry>
+  (utmpx type pid line id user host termination exit
+         session time address)
+  utmpx?
+  (type           utmpx-login-type)               ;login-type
+  (pid            utmpx-pid)
+  (line           utmpx-line)                     ;device name
+  (id             utmpx-id)
+  (user           utmpx-user)                     ;user name
+  (host           utmpx-host)                     ;host name | #f
+  (termination    utmpx-termination-status)
+  (exit           utmpx-exit-status)
+  (session        utmpx-session-id)               ;session ID, for windowing
+  (time           utmpx-time)                     ;entry time
+  (address        utmpx-address))
+
+(define-c-struct %utmpx                           ;<utmpx.h>
+  sizeof-utmpx
+  (lambda (type pid line id user host termination exit session
+                seconds useconds address %reserved)
+    (utmpx type pid
+           (bytes->string line) id
+           (bytes->string user)
+           (bytes->string host) termination exit
+           session
+           (make-time time-utc (* 1000 useconds) seconds)
+           address))
+  read-utmpx
+  write-utmpx!
+  (type           short)
+  (pid            int)
+  (line           (array uint8 32))
+  (id             (array uint8 4))
+  (user           (array uint8 32))
+  (host           (array uint8 256))
+  (termination    short)
+  (exit           short)
+  (session        int32)
+  (time-seconds   int32)
+  (time-useconds  int32)
+  (address-v6     (array int32 4))
+  (%reserved      (array uint8 20)))
+
+(define-bits login-type
+  %unused-login-type->symbols
+  (define EMPTY 0)                      ;No valid user accounting information.
+  (define RUN_LVL 1)                    ;The system's runlevel.
+  (define BOOT_TIME 2)                  ;Time of system boot.
+  (define NEW_TIME 3)                   ;Time after system clock changed.
+  (define OLD_TIME 4)                   ;Time when system clock changed.
+
+  (define INIT_PROCESS 5)                ;Process spawned by the init process.
+  (define LOGIN_PROCESS 6)               ;Session leader of a logged in user.
+  (define USER_PROCESS 7)                ;Normal process.
+  (define DEAD_PROCESS 8)                ;Terminated process.
+
+  (define ACCOUNTING 9))                 ;System accounting.
+
+(define setutxent
+  (let ((proc (syscall->procedure void "setutxent" '())))
+    (lambda ()
+      "Open the user accounting database."
+      (proc))))
+
+(define endutxent
+  (let ((proc (syscall->procedure void "endutxent" '())))
+    (lambda ()
+      "Close the user accounting database."
+      (proc))))
+
+(define getutxent
+  (let ((proc (syscall->procedure '* "getutxent" '())))
+    (lambda ()
+      "Return the next entry from the user accounting database."
+      (let ((ptr (proc)))
+        (if (null-pointer? ptr)
+            #f
+            (read-utmpx (pointer->bytevector ptr sizeof-utmpx)))))))
+
+(define (utmpx-entries)
+  "Return the list of entries read from the user accounting database."
+  (setutxent)
+  (let loop ((entries '()))
+    (match (getutxent)
+      (#f
+       (endutxent)
+       (reverse entries))
+      ((? utmpx? entry)
+       (loop (cons entry entries))))))
+
 ;;; syscalls.scm ends here
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index e4ef32c522..fb2c8e7100 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -441,6 +441,17 @@
   (> (terminal-columns (open-input-string "Join us now, share the software!"))
      0))
 
+(test-assert "utmpx-entries"
+  (match (utmpx-entries)
+    (((? utmpx? entries) ...)
+     (every (lambda (entry)
+              (match (utmpx-user entry)
+                ((? string?)
+                 (> (utmpx-pid entry) 0))
+                (#f                               ;might be DEAD_PROCESS
+                 #t)))
+            entries))))
+
 (test-end)
 
 (false-if-exception (delete-file temp-file))