New function: path-components-safe.

* autoload.c (path_test_set_entries): Autoload on
path-components-safe symbol.

* stdlib/path-test.tl (if-windows, if-native-windows):
New system macros.
(path-safe-sticky-dir): New system function.
(path-components-safe): New function.

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

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

5 files changed, 203 insertions, 20 deletions

diff --git a/autoload.c b/autoload.c
index f2ecfb11..b646f914 100644
--- a/autoload.c
+++ b/autoload.c
@@ -192,6 +192,7 @@ static val path_test_set_entries(val fun)
     lit("path-mine-p"), lit("path-my-group-p"), lit("path-executable-to-me-p"),
     lit("path-writable-to-me-p"), lit("path-readable-to-me-p"),
     lit("path-read-writable-to-me-p"),
+    lit("path-safe-sticky-dir"), lit("path-components-safe"),
     lit("path-newer"), lit("path-older"),
     lit("path-same-object"), lit("path-private-to-me-p"),
     lit("path-strictly-private-to-me-p"),
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 4efb6391..98a4b668 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -1423,6 +1423,7 @@
       ("path-blkdev-p" "N-00198FC7")
       ("path-cat" "N-0033B27E")
       ("path-chrdev-p" "N-00198FC7")
+      ("path-components-safe" "N-02451630")
       ("path-dir-empty" "N-01EFC15D")
       ("path-dir-p" "N-00198FC7")
       ("path-equal" "N-02365F9E")
diff --git a/stdlib/path-test.tl b/stdlib/path-test.tl
index 3288ef79..31a4d4be 100644
--- a/stdlib/path-test.tl
+++ b/stdlib/path-test.tl
@@ -152,6 +152,78 @@
                  (and (all g.mem (orf (op equal name)
                                       (op equal suname))))))))))
 
+(eval-only
+  (defmacro if-windows (then : else)
+    (if (eql 2 (sizeof wchar))
+      then
+      else))
+
+  (defmacro if-native-windows (then : else)
+    (if-windows
+      ^(if (find #\\ path-sep-chars) ,then ,else)
+      else)))
+
+(defun path-safe-sticky-dir (st)
+  (let ((sdir (logior s-ifdir s-isvtx)))
+    (and (eql (logand st.mode sdir) sdir)
+         (zerop st.uid))))
+
+(defun path-components-safe (path)
+  (let* ((comps (spl path-sep-chars path))
+         (start "/"))
+    (iflet ((head (car comps)))
+      (and
+        (if-native-windows
+          (match-case head
+            (@(or "" `@{vol #/[A-Za-z]+:/}`)
+              (set start `@head`
+                   comps (cdr comps))
+              (path-private-to-me-p start))
+            (`@{vol #/A-Za-z]+:/}@name`
+              (set start `@vol@name`
+                   comps (cdr comps))
+              (and (path-private-to-me-p `@vol`)
+                   (path-private-to-me-p start)))
+            (@else
+              (set start ".")
+              (let ((st (stat start)))
+                (or (path-private-to-me-p st)
+                    (path-safe-sticky-dir st)))))
+          (cond
+            ((empty head)
+              (set start "/"
+                   comps (cdr comps))
+              (path-private-to-me-p "/"))
+            (t
+              (set start ".")
+              (let ((st (stat start)))
+                (or (path-private-to-me-p st)
+                    (path-safe-sticky-dir st))))))
+      (for ((ok t) (count 0) next (orig-start start))
+           ((and ok (set next (pop comps))) ok)
+           ()
+        (let* ((nxpath (path-cat start next))
+               (st (lstat nxpath)))
+          (cond
+            ((eql (logand st.mode s-ifmt) s-iflnk)
+             (if (> (inc count) 16)
+               (throwf 'file-error "~a: too many symbolic links"
+                       'path-components-safe))
+             (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))))
+               (set ok nil)))
+            ((or (path-private-to-me-p st)
+                 (path-safe-sticky-dir st))
+             (set start nxpath))
+            (t (zap ok)))))))))
 
 (defmacro sys:path-examine ((sym statfun path) . body)
   ^[sys:do-path-test ,statfun ,path
diff --git a/tests/018/path-safe.tl b/tests/018/path-safe.tl
new file mode 100644
index 00000000..767ee752
--- /dev/null
+++ b/tests/018/path-safe.tl
@@ -0,0 +1,89 @@
+(load "../common")
+
+;; only root can do this test
+(unless (zerop (geteuid))
+  (exit))
+
+(defvarl testdir (mkdtemp `/tmp/txr-path-safe-test`))
+
+(push-after-load (remove-path-rec testdir))
+
+(chmod testdir "a+rX")
+
+(defvarl atestdir (realpath testdir))
+(defvarl tmpdir (path-cat testdir "tmp"))
+
+(mkdir tmpdir)
+(defvarl atmpdir (realpath tmpdir))
+(ensure-dir tmpdir)
+(chmod tmpdir "a+rwt")
+
+(seteuid 10000)
+(touch (path-cat tmpdir "10000"))
+(symlink "/" (path-cat tmpdir "10000-link"))
+(seteuid 0)
+
+(seteuid 20000)
+(touch (path-cat tmpdir "20000"))
+(symlink "/" (path-cat tmpdir "20000-link"))
+(seteuid 0)
+
+(mtest
+  (path-components-safe tmpdir) t
+  (path-components-safe (path-cat tmpdir "10000")) nil
+  (path-components-safe (path-cat tmpdir "10000-link")) nil
+  (path-components-safe (path-cat tmpdir "20000")) nil)
+
+(mtest
+  (path-components-safe atmpdir) t
+  (path-components-safe (path-cat atmpdir "10000")) nil
+  (path-components-safe (path-cat atmpdir "10000-link")) nil
+  (path-components-safe (path-cat atmpdir "20000")) nil)
+
+(seteuid 10000)
+
+(mtest
+  (path-components-safe atmpdir) t
+  (path-components-safe (path-cat tmpdir "10000")) t
+  (path-components-safe (path-cat tmpdir "10000-link")) t
+  (path-components-safe (path-cat tmpdir "20000")) nil
+  (path-components-safe (path-cat tmpdir "20000-link")) nil)
+
+(mtest
+  (path-components-safe atmpdir) t
+  (path-components-safe (path-cat atmpdir "10000")) t
+  (path-components-safe (path-cat atmpdir "10000-link")) t
+  (path-components-safe (path-cat atmpdir "20000")) nil
+  (path-components-safe (path-cat atmpdir "20000-link")) nil)
+
+(symlink "loop/x/y" (path-cat tmpdir "loop"))
+
+(test
+  (path-components-safe (path-cat tmpdir "loop/z")) :error)
+
+(chdir tmpdir)
+(symlink "b/c" "a")
+(ensure-dir "b")
+(symlink "x" "b/c")
+(touch "b/x")
+
+(test
+  (path-components-safe "a") t)
+
+(remove-path "b/c")
+
+(test
+  (path-components-safe "a") :error)
+
+(seteuid 0)
+(seteuid 20000)
+(symlink "x" "z")
+
+(seteuid 0)
+(rename-path "z" "b/c")
+(seteuid 10000)
+
+(test
+  (path-components-safe "a") nil)
+
+(seteuid 0)
diff --git a/txr.1 b/txr.1
index 78a836ef..3dd5ed0c 100644
--- a/txr.1
+++ b/txr.1
@@ -71610,28 +71610,48 @@ only the caller as a member. But by the time the file is subsequently accessed,
 the group might have been innocently extended by the system administrator to
 include additional users, who can maliciously modify the file.
 
-Also note that the function is vulnerable to a time-of-check to time-of-use
-race if
+Another issue is that if any components of
 .meta path
-is a string rather than a
-.code stat
-structure. If any components of the
-.meta path
-are symbolic links or directories that can be manipulated by other
-users, then the object named by
-.meta path
-file can pass the check, but can later
-.meta path
-can be subverted to refer to a different object.
+can be subverted by another user, test may not be trusted. It becomes
+vulnerable to a time-of-check to time-of-use race condition.
 
-One way to guard against this race is to open the file, then use
-.code fstat
-on the stream to obtain a
-.code stat
-structure which is then used as an argument to
-.code path-private-to-me-p
-or
-.codn path-strictly-private-to-me-p .
+The function
+.code path-components-safe
+function is provided to perform a security check on an entire path.
+
+.coNP Function @ path-components-safe
+.synb
+.mets (path-components-safe << path )
+.syne
+.desc
+The
+.code path-components-safe
+performs a security check on an entire relative or absolute
+.metn path ,
+returning
+.code t
+if the entire path is examined without encountering an error, and
+the check passes, otherwise
+.codn nil .
+
+An exception may be thrown if an an inaccessible or nonexistent path
+component is encountered, too many symbolic links have to be resolved
+or there is some other problem preventing the traversal of
+.metn path .
+
+The objective of this function is to determine that every portion of
+.code path
+is writable only to the effective user: that if the path is used for
+filesystem access, its meaning cannot be altered by an adversarial
+user who is able to control a symbolic link or a directory component.
+
+The function expands symbolic links on its own, one level at a time,
+and walks the components coming from a link target.
+
+Note: directories which are owned by root, and have the sticky bit, as
+is the usual configuration of
+.code tmp
+are considered safe, even though multiple users have write permissions.
 
 .coNP Functions @ path-newer and @ path-older
 .synb