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.

1 files changed, 42 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))