From 80b5cb9cea4a4d56455661678d896514312109eb Mon Sep 17 00:00:00 2001
From: Sean Whitton <spwhitton@spwhitton.name>
Date: Sun, 25 Jul 2021 13:03:57 -0700
Subject: add DEFINE-ERROR-RETVAL-CFUN, CHROOT, CLEARENV

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
---
 src/connection/chroot.lisp |  5 +----
 src/package.lisp           |  4 ++++
 src/util.lisp              | 37 +++++++++++++++++++++++++++++++++++--
 3 files changed, 40 insertions(+), 6 deletions(-)

diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index 6b3f29e..5ea3c7a 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -120,10 +120,7 @@ should be the mount point, without the chroot's root prefixed.")
       (connection-teardown connection))))
 
 (defmethod post-fork ((connection chroot.fork-connection))
-  (with-slots (into) connection
-    (unless (zerop
-             (foreign-funcall "chroot" :string (unix-namestring into) :int))
-      (error "chroot(2) failed!")))
+  (chroot (unix-namestring (slot-value connection 'into)))
   (let ((home (connection-connattr connection :remote-home)))
     (setf (getenv "HOME") (unix-namestring home))
     ;; chdir, else our current working directory is a pointer to something
diff --git a/src/package.lisp b/src/package.lisp
index 74d9fa4..748b45d 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -125,6 +125,10 @@
            #:return-exit
            #:posix-login-environment
 
+           #:define-error-retval-cfun
+
+           #:chroot
+
            ;; connection.lisp
            #:establish-connection
            #:continue-connection
diff --git a/src/util.lisp b/src/util.lisp
index 74e2801..f23cfb0 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -584,8 +584,7 @@ Does not currently establish a PAM session."
     (let ((preserved (loop for var in maybe-preserve
                            for val = (getenv var)
                            when val collect var and collect val)))
-      (unless (zerop (foreign-funcall "clearenv" :int))
-        (failed-change "clearenv(3) failed!"))
+      (clearenv)
       (loop for (var val) on preserved by #'cddr do (setf (getenv var) val)))
     (setf (getenv "HOME") (drop-trailing-slash (unix-namestring home))
           (getenv "USER") logname
@@ -597,6 +596,40 @@ Does not currently establish a PAM session."
               "/usr/local/bin:/bin:/usr/bin"))
     (uiop:chdir home)))
 
+
+;;;; System and libc calls which can fail
+
+;;; Osicat has an implementation of this but it's not exported.  However, we
+;;; are able to instantiate Osicat's POSIX-ERROR to simplify errno handling.
+
+(defmacro define-error-retval-cfun
+    ((&key (errno t) (failure-val -1)) &body defcfun-args)
+  (let ((defun (etypecase (car defcfun-args)
+                 (string (intern (string-upcase (car defcfun-args))))
+                 (list (cadar defcfun-args))))
+        (cfun (etypecase (car defcfun-args)
+                (string (car defcfun-args))
+                (list (caar defcfun-args)))))
+    `(defun ,defun ,(loop for arg in (cddr defcfun-args) collect (car arg))
+       ,@(and (eql errno :zero) '((nix:set-errno 0)))
+       (let ((result (foreign-funcall
+                      ,cfun
+                      ,@(loop for arg in (cddr defcfun-args)
+                              collect (cadr arg) collect (car arg))
+                      ,(cadr defcfun-args))))
+         (if ,(if (eql errno :zero)
+                  `(and (= ,failure-val result) (not (zerop (nix:get-errno))))
+                  `(= ,failure-val result))
+             (nix:posix-error ,(and errno '(nix:get-errno)) nil ',defun)
+             result)))))
+
+
+;;;; Miscellaneous system functions
+
+(define-error-retval-cfun () "clearenv" :int)
+
+(define-error-retval-cfun () "chroot" :int (path :string))
+
 
 ;;;; Lisp data files
 
-- 
cgit v1.2.3