04/07: syscalls: add missing pieces for derivation build environment

[guix-commits]

reepca pushed a commit to branch guile-daemon
in repository guix.

commit 8da68543504b889d4fe433036925cb62d97abb6d
Author: Caleb Ristvedt <address@hidden>
AuthorDate: Thu Dec 12 07:18:33 2019 -0600

    syscalls: add missing pieces for derivation build environment
    
    * guix/build/syscalls.scm (ADDR_NO_RANDOMIZE, UNAME26, PER_LINUX32): new
      variables. Flags needed for improving determinism / impersonating a 32-bit
      machine on a 64-bit machine.
      (initialize-loopback, setdomainname, personality): New procedures. Needed 
in
      setting up container.
      (octal-escaped): New procedure.
      (mount-points): uses octal-escaped to properly handle unusual characters 
in
      mount point filenames.
---
 guix/build/syscalls.scm | 70 ++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 67 insertions(+), 3 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index b9d1938..667cb8b 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -114,6 +114,7 @@
             configure-network-interface
             add-network-route/gateway
             delete-network-route
+            initialize-loopback
 
             interface?
             interface-name
@@ -161,7 +162,12 @@
             utmpx-address
             login-type
             utmpx-entries
-            (read-utmpx-from-port . read-utmpx)))
+            (read-utmpx-from-port . read-utmpx)
+            personality
+            ADDR_NO_RANDOMIZE
+            setdomainname
+            UNAME26
+            PER_LINUX32))
 
 ;;; Commentary:
 ;;;
@@ -509,6 +515,27 @@ constants from <sys/mount.h>."
       (when update-mtab?
         (remove-from-mtab target)))))
 
+(define (octal-escaped str)
+  "Convert a string that may contain octal-escaped characters of the form \\ooo
+to a string with the corresponding code points."
+    ;; I'm using "octet" here like I would normally use "digit".
+  (define (octal-triplet->char octet1 octet2 octet3)
+   (integer->char (string->number (string octet1 octet2 octet3)
+                                   8)))
+
+  (let next-char ((result-list '())
+                  (to-convert (string->list str)))
+    (match to-convert
+      ((#\\ octet1 octet2 octet3 . others)
+       (next-char (cons (octal-triplet->char octet1 octet2 octet3)
+                        result-list)
+                  others))
+      ((char . others)
+       (next-char (cons char result-list)
+                  others))
+      (()
+       (list->string (reverse! result-list))))))
+
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."
   (call-with-input-file "/proc/mounts"
@@ -519,7 +546,7 @@ constants from <sys/mount.h>."
               (reverse result)
               (match (string-tokenize line)
                 ((source mount-point _ ...)
-                 (loop (cons mount-point result))))))))))
+                 (loop (cons (octal-escaped mount-point) result))))))))))
 
 (define swapon
   (let ((proc (syscall->procedure int "swapon" (list '* int))))
@@ -1558,6 +1585,16 @@ is true, it must be a socket address to use as the 
network mask."
       (lambda ()
         (close-port sock)))))
 
+(define (initialize-loopback)
+  (let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_IP)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (set-network-interface-flags sock "lo"
+                                     (logior IFF_UP IFF_LOOPBACK IFF_RUNNING)))
+      (lambda ()
+        (close sock)))))
+
 
 ;;;
 ;;; Network routes.
@@ -2074,4 +2111,31 @@ entry."
     ((? bytevector? bv)
      (read-utmpx bv))))
 
-;;; syscalls.scm ends here
+;; TODO: verify these constants are correct on platforms other than x86-64
+(define ADDR_NO_RANDOMIZE #x0040000)
+(define UNAME26           #x0020000)
+(define PER_LINUX32          #x0008)
+
+(define personality
+  (let ((proc (syscall->procedure int "personality" `(,unsigned-long))))
+    (lambda (persona)
+      (let-values (((ret err) (proc persona)))
+        (if (= -1 ret)
+            (throw 'system-error "personality" "~A"
+                   (list (strerror err))
+                   (list err))
+            ret)))))
+
+(define setdomainname
+  (let ((proc (syscall->procedure int "setdomainname" (list '* int))))
+    (lambda (domain-name)
+      (let-values (((ret err) (proc (string->pointer/utf-8 domain-name)
+                                    (bytevector-length (string->utf8
+                                                        domain-name)))))
+        (if (= -1 ret)
+            (throw 'system-error "setdomainname" "~A"
+                   (list (strerror err))
+                   (list err))
+            ret)))))
+
+;;; syscalls.scm ends here