Skip to content

Commit

Permalink
bug24246: Check for and invalidate out of date file handles
Browse files Browse the repository at this point in the history 
I made changes to the function (insert-fhandle) which handles
insertion of new file handles into caching data structures.
Previously the function assumed that the id of a new file handle had
never been used before.  However, if a file or directory has been
renamed outside of the knowledge of Allegro NFS, then it's possible
that the "new" file/dir will have the same file id as an existing
entry.

I changed the function to check for the existence of a file handle w/
the same id before doing anything else [Note: It only performs this
check if the current operation is not an internal rename operation].
If such a file handle is found, it is invalidated before continuing w/
the insertion of the new entry.  This prevents Allegro NFS from
holding on to out-of-date information.

The new check for existing file ids will cost additional CPU time when
new file handles are being inserted.  New file handles are inserted
the first time a file is "seen" by Allegro NFS.  The check amounts to
a hash table lookup so the cost is low.

Simplified the way that export name canonicalization and searching
works.  Added some related utility functions.

Made locate-nearest-export-by-nfs-path operate correctly when using
submounts.

Change-Id: I219295283c3bd2ad6e64c527655bc6de9d798494
Reviewed-on: https://gerrit.franz.com:9080/6585
Reviewed-by: Ahmon Dancy <dancy@franz.com>
Reviewed-by: Kevin Layer <layer@franz.com>
Tested-by: Kevin Layer <layer@franz.com>
  • Loading branch information
@dancysoft @dklayer
dancysoft authored and dklayer committed Oct 26, 2016
1 parent 348111f commit d1683ac
Show file tree
Hide file tree
Showing 4 changed files with 175 additions and 54 deletions.
77 changes: 58 additions & 19 deletions export.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,12 @@
;; couldn't use "export" or "exp"
(defstruct nfs-export
id
name

;; Canonicalized name. This will either be the string "/", or a
;; string that begins with a slash and which does not have a
;; trailing slash.
name

path
uid
gid
Expand All @@ -21,7 +26,7 @@
hosts-allow
rw-users
ro-users
match)
)

(defun prepare-exports ()
(mp:with-process-lock (*exports-lock*)
Expand All @@ -47,10 +52,6 @@
else
(remove-duplicates res :test #'equalp))))

(defun build-export-match (name)
"Builds a regular expression for use."
(compile-re (format nil "^~A(/.*)?$" name)))

(defun define-export (&key name path (uid 9999) (gid 9999)
(umask 0) (set-mode-bits 0)
hosts-allow rw-users ro-users
Expand All @@ -76,7 +77,7 @@
:hosts-allow (expand-access-list hosts-allow host-lists)
:rw-users (expand-access-list rw-users user-lists)
:ro-users (expand-access-list ro-users user-lists)
:match (build-export-match canonical-name))))))
)))))
(logit-stamp "Export with name '~A' isn't an acceptable name, flush your configuration and reconfigure!"
name))))

Expand Down Expand Up @@ -130,19 +131,56 @@
(dolist (exp *old-exports*)
(invalidate-export-fhandles exp))))

;; Assumptions:
;; * The caller has verified that trailing-slashified EXPORT-NAME
;; is a prefix of trailing-slashified REQUESTED-PATH.
(defun compute-tail-path (export-name requested-path)
"EXPORT-NAME and REQUESTED-PATH must be canonicalized names
If REQUESTED-PATH is equal to EXPORT-NAME, returns NIL. This
indicates that there is no attempt to mount a directory within
the export.
If REQUESTED-PATH is a subpath of EXPORT-NAME, returns a
string containing the subpath without a leading slash (and,
since REQUESTED-PATH is a canonical path, without a trailing
slash."
(let* ((export-name-len (length export-name))
(requested-path-len (length requested-path)))
(when (> requested-path-len export-name-len)
(if* (= export-name-len 1)
then ;; export name must be "/". Sanity check.
(assert (string= export-name "/"))
(subseq requested-path 1)
else
(subseq requested-path (1+ export-name-len))))))

;; Called by mount::mountproc-mnt-common, :operator
(defun locate-nearest-export-by-nfs-path (path)
(mp:with-process-lock (*exports-lock*)
(if (null *exports*)
(return-from locate-nearest-export-by-nfs-path nil))
(let (exp)
(dotimes (n (length *exports*))
(setf exp (svref *exports* n))
(multiple-value-bind (ok match tail)
(match-re (nfs-export-match exp) path)
(when (and ok match)
(return-from locate-nearest-export-by-nfs-path
(values exp
(or tail "")))))))))
"PATH is provided by the NFS client when requesting
a file handle during a MOUNT request.
If PATH cannot be canonicalized, NIL is returned.
Returns NIL if PATH does not correspond to any
defined export.
"
(when (setf path (ignore-errors (canonicalize-name path)))
;; We scan the sorted exports using a trailing slash so that we know that
;; we're making comparisons at path-component boundaries.
(let ((slashified-path (trailing-slashify path)))
(mp:with-process-lock (*exports-lock*)
(if (null *exports*)
(return-from locate-nearest-export-by-nfs-path nil))

;; *exports* is sorted so that the longest export names are first
(loop for exp in-sequence *exports*
do (let* ((export-name (nfs-export-name exp))
(slashified-export-name (trailing-slashify export-name)))
(when (prefixp slashified-export-name slashified-path)
;; Found the best export. Collect information about any
;; subdirectory of the mount that was requested.
(return (values exp (compute-tail-path export-name path))))))))))

(defun extract-path-drive-and-tail (path)
(multiple-value-bind (matched whole drive tail)
Expand Down Expand Up @@ -233,6 +271,7 @@
(error "(real-path-prefix-p ~s ~s) returned ~s but expected ~s"
path prefix got expected-result)))))))

;; Called by recover-persistent-fh, :operator
(defun locate-nearest-export-by-real-path (path)
(let (best-export best-tail)
(mp:with-process-lock (*exports-lock*)
Expand Down
65 changes: 46 additions & 19 deletions fhandle.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -190,7 +190,7 @@
fh-file-id
"
(let* ((fh
;; special case for root of exports
;; special case for root of exports.
(if* root-export
then
(make-fh :pathname filename
Expand All @@ -207,11 +207,20 @@

fh))

;; Used by mountd
;; 'tail' is guaranteed to have no leading or trailing slash
;;;Called by:
;;;recover-persistent-fh, :operator
;;;mount::mountproc-mnt-common, :operator
(defun get-fhandle-for-path (tail exp)
"TAIL must either be NIL, in which case the file handle of EXP is returned,
or TAIL must be a string representing a subpath below EXP. TAIL
must not have leading or trailing slashes.
Returns the file handle associated with the specified subpath
of EXP. Returns NIL if no such file or directory is found."

(let ((dirfh (get-export-fhandle exp)))
(when (string/= tail "")
(when tail
;; Split TAIL on slash or backslash.
(dolist (comp (split-re "[\\\\/]" tail))
(let ((fh (nfs-probe-file dirfh comp)))
(if* (null fh)
Expand All @@ -222,7 +231,7 @@
(defun get-export-fhandle (exp)
;; See if it has already been assigned.
(let* ((path (nfs-export-path exp))
(fh (gethash path *export-roots*)))
(fh (gethash path *export-roots*)))
(if* fh
then fh
else ;; first use.
Expand All @@ -237,21 +246,39 @@

;; Put a fhandle into the hash.. and make sure the
;; parent has a child entry. FILENAME must be a basename.
(defun insert-fhandle (fh filename)
(let ((debug t))
(when debug
(let ((prior-fh (gethash (fh-vec fh) *fhandles*)))
(when prior-fh
;; FIXME: What else can we do? We need
;; to fix up the parent's state
(logit-stamp "
Replacing mapping for fileid ~a in *fhandles*.
Was ~a, now ~a"
(defun insert-fhandle (fh filename rename)
(when (not rename)
(let ((prior-fh (gethash (fh-vec fh) *fhandles*))
(debug nil))
(when prior-fh
;; We reach here if there is already an existing entry in *fhandles*
;; for the file-id of FH. Scenarios which could result in
;; this state:
;; * A file or directory was renamed/moved outside of Allegro NFS.
;; * A file id was recycled. This seems to be a low probability event.
;; * A new hard link is discovered. In this case the removal of the
;; prior entry from the parent fh is not the wrong thing to do.
;; However, I don't think it's a big deal. In the worst case, alternating
;; access to each of the hard link names will result in repeated adjustment
;; of the file handle database.
;; * ??

(when debug
(logit-stamp "~%Replacing mapping for fileid ~a in *fhandles*.~%Was ~a, now ~a~%"
(fh-file-id fh)
(fh-pathname prior-fh)
(fh-pathname fh))))))
(fh-pathname fh)))

;; Remove knowledge of the old basename from the parent
;; since we know that it is out of date.
(remove-fhandle prior-fh (basename (fh-pathname prior-fh)))
;; If prior-fh refers to a directory, invalidate-fhandles will recursively
;; remove information about its children.
(invalidate-fhandles prior-fh)))

(setf (gethash (fh-vec fh) *fhandles*) fh))
;; end (when (not rename).. )

(setf (gethash (fh-vec fh) *fhandles*) fh)
(let ((parent (fh-parent fh)))
(if (null parent)
(error "insert-fhandle: ~S has no parent" fh))
Expand Down Expand Up @@ -295,7 +322,7 @@ Was ~a, now ~a"
(format t "lookup-fh-in-dir(~a,~a) making new fh.~%"
dirfh filename)

(insert-fhandle (make-fhandle dirfh filename :lookup) filename))))
(insert-fhandle (make-fhandle dirfh filename :lookup) filename nil))))

;; Called by:
;; remove-fhandle, rename-fhandle, nfsd-link
Expand Down Expand Up @@ -382,7 +409,7 @@ Was ~a, now ~a"
;; update our parent slot
(setf (fh-parent fh) todir)
;; add to destination parent.
(insert-fhandle fh tofilename)
(insert-fhandle fh tofilename t)

;; FIXME: This doesn't check for hard links that may have been
;; moved to another directory (which will break things). The whole
Expand Down
22 changes: 19 additions & 3 deletions mountd.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -80,12 +80,28 @@
(defun mountproc3-null (arg vers peer cbody)
(mountproc-null arg vers peer cbody))

;; Note: DIRPATH is provided by the NFS client so we need to be clear
;; about what we accept and what it means.
;;
;; Constraints:
;; * DIRPATH cannot be a blank string. This means that we cannot allow blank
;; export names. I think this is a reasonable restriction.
;; * DIRPATH must have a leading slash.
;; * DIRPATH may or may not have trailing slashes. If there are
;; trailing slashes, they will be ignored. This means that export
;; names are not allowed to have trailing slashes.
;;
;; These contraints are verified and enforced by
;; user::locate-nearest-export-by-nfs-path and its helpers.

(defun mountproc-mnt-common (dirpath vers peer)
"Returns the file handle (fh struct) corresponding to DIRFH if
successful. Otherwise returns an NFS error code"
(if *mountd-debug*
(user::logit-stamp "MNT~d: ~a: MOUNT ~a "
vers (sunrpc:peer-dotted peer) dirpath))
(multiple-value-bind (exp tail)
(user::locate-nearest-export-by-nfs-path dirpath)
(if *mountd-debug*
(user::logit-stamp "MNT~d: ~a: MOUNT ~a "
vers (sunrpc:peer-dotted peer) dirpath))
(if* (null exp)
then (if *mountd-debug* (user::logit "==> Denied (no such export).~%"))
gen-nfs:*nfserr-noent*
Expand Down
65 changes: 52 additions & 13 deletions nfs-shared.cl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -69,25 +69,64 @@
(compile-re "^/(?:.*[^/])?$")
"A regexp to match canonical names. The rules of which are the following:
1) must begin with a #\/
1) must begin with a slash (therefore cannot be a blank string)
2) may or may not have more path.
3) must not end with a #\/.")
3) must not end with a slash, unless the string consists only of a single
slash")

(defun canonical-name-p (name)
"Returns true if a name is canonical."
(when (match-re *canonical-name-regexp* name)
t))

(defvar *canonicalize-name-regexp*
(compile-re "^(/.*[^/])|(/)$")
"A regexp to return a valid match. There are two captures and
if there is a match then one or the other is to be used.
They are mutually exclusive.")
(defun eat-trailing-slashes (name)
"Returns a version of NAME without trailing slashes
unless NAME is a single slash, in which case NAME is returned.
The returned string may or may not be eq to NAME."

;; This code is simple and easy to understand. Don't bother
;; optimizing it. It's not currently used in performance-critical
;; code.

(let ((len (length name)))
(if* (<= len 1)
then ;; Base case. Blank or single-character string.
;; "/" technically has a trailing slash, but it must not be removed.
;; We're done.
name
else (let ((last-char (char name (1- len))))
(if* (char= last-char #\/)
then ;; Multiple-character string with trailing
;; slash. Drop the trailing slash
;; and recurse.
(eat-trailing-slashes (subseq name 0 (1- len)))
else ;; No trailing slash. done.
name)))))

;; Called by define-export, :operator
(defun canonicalize-name (name)
"Standardizes export names."
(if (canonical-name-p name)
name
(multiple-value-bind (ok match complex-match simple-match)
(match-re *canonicalize-name-regexp* name)
(and ok match (or complex-match simple-match)))))
"Returns a canonicalized version of NAME if possible.
* If NAME does not begin with a slash, an error is thrown.
* If NAME consists of a single slash, NAME is returned.
* Otherwise, a version of NAME with all trailing slashes removed is
returned. The returned string may or may not be eq to NAME."

(when (not (prefixp "/" name))
(error "~s: NAME must begin with a slash" name))

(eat-trailing-slashes name))

(defun trailing-slashify (string)
"If STRING has a trailing slash, returns STRING.
If STRING is a single slash, returns STRING.
Otherwise returns a copy of STRING with a trailing slash.
Note that this means if STRING is blank, a string consisting
of a single slash will be returned."
(if* (or (match-re "/$" string)
(string= string "/"))
then string
else (concatenate 'string string "/")))

0 comments on commit d1683ac

Please sign in to comment.