path-components-safe: repel /proc symlink attacks

In a Linux system, it's possible for an unprivileged
user to create a root symlink pointing to any directory,
simply by changing to that directory and running a setuid
executable like "su". That executable will get a process
whose /proc/<pid> directory is root owned, and contains
a symlink named cwd pointing to the current directory.
Other symlinks under /proc look exploitable in this way.

* stdlib/path-test.tl (safe-abs-path): New function.
Here is where we are going to check for unsafe paths.
We use some pattern matching to recognize various unsafe
symlinks under /proc.
(path-components-safe): Simplify code around recognition
of absolute paths. When an absolute path is read from
a symlink, remove the first empty component. Pass every
absolute path through safe-abs-path to check for known
unsafe paths.

* tests/018/path-safe.tl: New tests.

2 files changed, 67 insertions, 17 deletions

diff --git a/stdlib/path-test.tl b/stdlib/path-test.tl
index 9edbf5b3..c750841e 100644
--- a/stdlib/path-test.tl
+++ b/stdlib/path-test.tl
@@ -180,19 +180,40 @@
     (and (eql (logand st.mode sdir) sdir)
          (zerop st.uid))))
 
+(defun safe-abs-path (comps)
+  (flet ((digstr (s) [all s chr-isdigit]))
+    (let ((safe t))
+      (if (zerop (geteuid))
+        (when-match ("proc" @(or @(digstr) "self") . @rest)
+                    (path-simplify comps)
+          (match-case rest
+            (@(or ("cwd" . @nil)
+                  ("root" . @nil)
+                  ("map_files" . @nil)
+                  ("fd" @(digstr) . @nil))
+             (zap safe))
+            (("task" @(digstr) . @trest)
+             (match-case trest
+               (@(or ("cwd" . @nil)
+                     ("root" . @nil)
+                     ("fd" @(digstr) . @nil))
+                (zap safe)))))))
+      safe)))
+
 (defun path-components-safe (path)
   (if-native-windows
     t
-    (let* ((comps (spl path-sep-chars path))
-           (head (car comps))
-           (start "/"))
-      (if (empty head)
-        (set comps (cdr comps))
-        (set start "."))
-      (if (let ((st (stat start)))
-            (or (path-private-to-me-p st)
-                (if (nequal start "/")
-                  (path-safe-sticky-dir st))))
+    (let* ((abs-p (abs-path-p path))
+           (comps (sspl path-sep-chars path))
+           (comps (if abs-p (cdr comps) comps))
+           (start (if abs-p "/" ".")))
+      (if (and
+            (nullify path)
+            (or (not abs-p) (safe-abs-path comps))
+            (let ((st (stat start)))
+              (or (path-private-to-me-p st)
+                  (if (nequal start "/")
+                    (path-safe-sticky-dir st)))))
         (for ((ok t) (count 0) next (orig-start start))
              ((and ok (set next (pop comps))) ok)
              ()
@@ -206,13 +227,17 @@
                (if (or (zerop st.uid)
                        (eql st.uid (geteuid)))
                  (let* ((target (readlink nxpath))
-                        (tcomps (spl path-sep-chars target)))
-                   (set comps (nconc tcomps comps))
-                   (when (abs-path-p target)
-                     (set start "/")
-                     (if (nequal orig-start "/")
-                       (set ok (path-private-to-me-p "/")
-                            orig-start nil))))
+                        (abs-p (abs-path-p target))
+                        (tcomps (sspl path-sep-chars target))
+                        (tcomps (if abs-p (cdr tcomps) tcomps)))
+                   (when abs-p
+                     (set start "/"
+                          ok (and (safe-abs-path comps)
+                                  (if (nequal orig-start "/")
+                                    (set orig-start nil)
+                                    t))))
+                   (when ok
+                     (set comps (nconc tcomps comps))))
                  (set ok nil)))
               ((or (path-private-to-me-p st)
                    (path-safe-sticky-dir st))
diff --git a/tests/018/path-safe.tl b/tests/018/path-safe.tl
index 767ee752..2c86ca3e 100644
--- a/tests/018/path-safe.tl
+++ b/tests/018/path-safe.tl
@@ -86,4 +86,29 @@
 (test
   (path-components-safe "a") nil)
 
+(mtest
+  (path-components-safe "/proc/1") t
+  (path-components-safe "/proc/1/cwd") :error
+  (path-components-safe "/proc/self/cwd") t)
+
 (seteuid 0)
+
+(mtest
+  (path-components-safe "/proc/1") t
+  (path-components-safe "/proc/1/fd") t
+  (path-components-safe "/proc/sys/../1") t
+  (path-components-safe "/proc/1/cwd") nil
+  (path-components-safe "/proc/1/cwd/foo") nil
+  (path-components-safe "/proc/self/cwd") nil
+  (path-components-safe "/proc/self/cwd/foo") nil
+  (path-components-safe "/proc/1/root") nil
+  (path-components-safe "/proc/1/root/foo") nil
+  (path-components-safe "/proc/1/fd/0") nil
+  (path-components-safe "/proc/1/fd/0/bar") nil
+  (path-components-safe "/proc/1/map_files") nil
+  (path-components-safe "/proc/1/map_files/bar") nil
+  (path-components-safe "/proc/sys/../1/cwd") nil
+  (path-components-safe "/proc/1/task/1") t
+  (path-components-safe "/proc/1/task/1/fd/0") nil
+  (path-components-safe "/proc/1/task/1/cwd") nil
+  (path-components-safe "/proc/1/task/1/root") nil)