├── .gitignore ├── .modules ├── CHECKLIST ├── LICENSE ├── Makefile ├── README.md ├── anfs-version ├── attr.cl ├── bin └── verify_modules.sh ├── bswap.cl ├── config-defs.cl ├── configure.cl ├── configure ├── .gitignore ├── Makefile ├── buildit.cl ├── configform.bil ├── configform.cl ├── configure.exe.manifest ├── configure.lpr ├── export.cl ├── help-form.bil ├── help-form.cl └── nfs-server-io.cl ├── dir.cl ├── directory-tree.cl ├── doc ├── C702.PDF ├── access-control.txt ├── configuration.txt ├── debugging.txt ├── nlm.html ├── nlm.txt ├── notes.txt ├── profiling.txt ├── release-notes.txt ├── rfc1014-xdr-1987.txt ├── rfc1057-rpcv2-1988.txt ├── rfc1094-nfsv2-1989.txt ├── rfc1813-nfsv3-1995.txt ├── rfc1831-rpcv2-1995.txt ├── rfc1833-rpcbind-1995.txt ├── rfc5531-rpcv2-2009.txt ├── testing.txt └── todo.txt ├── export.cl ├── fhandle.cl ├── interval.cl ├── ipaddr.cl ├── license-demo.txt ├── license-paid.txt ├── license.readme ├── license.txt ├── load.cl ├── locking.cl ├── main.cl ├── misc └── nfscleanreg.vbs ├── mount.x ├── mountd.cl ├── nfs-common.cl ├── nfs-log.cl ├── nfs-shared.cl ├── nfs.cfg.default ├── nfs.cl ├── nfs.ico ├── nfs.nsi ├── nfs.x ├── nlm.cl ├── nlm.x ├── nsm.cl ├── nsm.x ├── openfile.cl ├── portmap.cl ├── portmap.x ├── results ├── 5.1 ├── 6.0.0 ├── 6.1.0 ├── 6.2.0 ├── 6.3.0 ├── 6.3.2.rc1 ├── 6.3.2.rc2 ├── 6.3.3.rc1 ├── 6.3.3.xp.rc1 └── 6.4.beta.1.rc1 ├── rpcgen.cl ├── servicelib.nsh ├── sunrpc-service.cl ├── sunrpc.cl ├── sunrpc.x ├── telnet.cl ├── test ├── .gitignore ├── Makefile ├── bigfile-test.sh ├── genfiles.c ├── hammernfs-libs │ ├── compat.h │ ├── mount.h │ ├── mount_clnt.c │ ├── mount_svc.c │ ├── mount_xdr.c │ ├── nfs.h │ ├── nfs_clnt.c │ ├── nfs_svc.c │ └── nfs_xdr.c ├── hammernfs.c ├── misc-tests.sh ├── nfs-common.c ├── nfs-common.h ├── performance.sh ├── results.cl ├── stress-test.sh ├── test-big-readdir-udp.c ├── test-conn-reset.c ├── test-nfs-low.c └── testnfs.c ├── unicode-file.cl ├── utf8.cl ├── utils.cl ├── xdr-get-signed-int.lap ├── xdr-store-signed-int.lap └── xdr.cl /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.tmp 3 | *.zip 4 | *~ 5 | /Makefile.local 6 | /autoloads.out 7 | /build.out 8 | /commit-id.cl 9 | /configure/module-report.txt 10 | /configure/configform.bak 11 | /demoware/ 12 | /dists/ 13 | /gen-nfs-client.cl 14 | /gen-nfs-common.cl 15 | /gen-nfs-server.cl 16 | /hammernfs 17 | /hammernfs.exe 18 | /mount-client.cl 19 | /mount-common.cl 20 | /mount-server.cl 21 | /nfs 22 | /nfs.cfg 23 | /nlm-client.cl 24 | /nlm-common.cl 25 | /nlm-server.cl 26 | /nsm-client.cl 27 | /nsm-common.cl 28 | /nsm-server.cl 29 | /portmap-client.cl 30 | /portmap-common.cl 31 | /portmap-server.cl 32 | /sunrpc-common.cl 33 | /testnfs 34 | /test-big-readdir-udp 35 | /test-nfs-low 36 | /TAGS 37 | -------------------------------------------------------------------------------- /.modules: -------------------------------------------------------------------------------- 1 | . 2 | demoware 3 | -------------------------------------------------------------------------------- /CHECKLIST: -------------------------------------------------------------------------------- 1 | Before a push: 2 | 3 | 1. Update README.md 4 | 5 | 2. Consider bumping the version number in nfs-common.cl 6 | 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Copyright (C) Franz, Inc. All rights reserved. 3 | 4 | This code is free software; you can redistribute it and/or modify it 5 | under the terms of the version 2.1 of the GNU Lesser General Public 6 | License as published by the Free Software Foundation, as clarified by 7 | the Franz preamble to the LGPL found in 8 | http://opensource.franz.com/preamble.html. 9 | 10 | This code is distributed in the hope that it will be useful, but 11 | without any warranty; without even the implied warranty of 12 | merchantability or fitness for a particular purpose. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | Version 2.1 of the GNU Lesser General Public License can be found at 16 | http://opensource.franz.com/license.html. If it is not present, you 17 | can access it from http://www.gnu.org/copyleft/lesser.txt (until 18 | superseded by a newer version) or write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | # NFS makefile (requires Cygwin and GNU make) 3 | # 4 | # Rules of note: 5 | # 6 | # - make the 32-bit and 64-bit versions 7 | # $ make all ...other make args, see below... 8 | # 9 | # - make release candidate 2: 10 | # $ make all release_suffix=rc2 11 | # 12 | # - make demo and non-demo versions: 13 | # $ make clean dist dist-demo LISPDIR=/c/acl90.patched 14 | # 15 | # - remove tag to build without changing version #: 16 | # $ make delete_tag release_suffix=rc1 17 | # 18 | ############################################################################### 19 | 20 | # chosen because it seems to work on thor and for spr42738 21 | #ACL_BUILD_ACLMALLOC_HEAP_START = 0x8ab0000 22 | 23 | DO_MAKEFILE_LOCAL := $(shell if test -f Makefile.local; then echo yes; fi) 24 | 25 | ifeq ($(DO_MAKEFILE_LOCAL),yes) 26 | include Makefile.local 27 | endif 28 | 29 | NEWSDKDIR = /c/Program Files (x86)/Windows Kits/10/bin/x86 30 | NEWSDK = $(shell if test -d "$(NEWSDKDIR)"; then echo yes; else echo no; fi) 31 | ifeq ($(NEWSDK),yes) 32 | FICODESIGN = ficodesign 33 | # Add the directory containing "signtool.exe" to PATH so scm-bin/ficodesign can find it 34 | PATH := $(PATH):$(NEWSDKDIR) 35 | endif 36 | 37 | # The variable NFSWIDTH specifies a 64bit version; 38 | VCREDIST ?= $(shell if test "$(NFSWIDTH)" = "64"; then echo x64; else echo x86; fi) 39 | defaultlisp = $(shell if test "$(NFSWIDTH)" = "64"; then echo .64.patched; else echo .patched; fi) 40 | LISPDIR ?= /c/acl10.1$(defaultlisp) 41 | LISPEXE = $(LISPDIR)/mlisp 42 | MAKENSIS ?= "/cygdrive/c/Program Files (x86)/NSIS/makensis.exe" 43 | 44 | # The variable VER_SUFFIX specifies a modifier appended to the 45 | # name of the installer and to the name of the installed application. 46 | 47 | version := $(shell ./anfs-version) 48 | 49 | default: build 50 | 51 | # use `dists' because `dist dist-demo' does not work.. see comment below 52 | # near `dists' for why. 53 | all: 54 | $(MAKE) $(MFLAGS) clean dists NFSWIDTH=64 NFSLISPBSW=yes VER_SUFFIX=-64 55 | $(MAKE) $(MFLAGS) clean dists 56 | $(MAKE) $(MFLAGS) tag FORCE=$(FORCE) 57 | 58 | MODULES = demoware:master 59 | 60 | prereqs: FORCE 61 | @bin/verify_modules.sh $(MODULES) 62 | 63 | ifdef release_suffix 64 | tag_name = nfs-$(version)-$(release_suffix) 65 | else 66 | tag_name = nfs-$(version) 67 | endif 68 | 69 | check_tag_name: FORCE 70 | ifndef FORCE 71 | @if git tag | grep -q '^$(tag_name)$$'; then \ 72 | echo ERROR: git tag $(tag_name) already exists; \ 73 | exit 1; \ 74 | else \ 75 | echo '**** TAG: $(tag_name)'; \ 76 | fi 77 | endif 78 | 79 | commit-id.cl: FORCE 80 | echo -n '(defvar *nfsd-commit-id* "' > commit-id.cl 81 | echo -n `git log -n1 --pretty=format:%H HEAD` >> commit-id.cl 82 | echo -n '")' >> commit-id.cl 83 | 84 | tag: FORCE 85 | git.sh tag -a -m $(tag_name) $(FORCE) $(tag_name) HEAD 86 | @echo NOTE: do this to push the tag: 87 | @echo git.sh push origin $(tag_name) 88 | 89 | delete_tag: FORCE 90 | git.sh tag -d $(tag_name) 91 | git.sh push origin :refs/tags/$(tag_name) 92 | 93 | build: check_cpp 94 | $(MAKE) $(MFLAGS) do_build 95 | 96 | check_cpp: FORCE 97 | @if ! which cpp > /dev/null 2>&1; then \ 98 | echo Error: cpp not installed.; \ 99 | exit 1; \ 100 | fi 101 | 102 | build-demo: FORCE 103 | $(MAKE) $(MFLAGS) DEMOWARE=xxx do_build 104 | 105 | ifdef ACL_BUILD_ACLMALLOC_HEAP_START 106 | env = env ACL_BUILD_ACLMALLOC_HEAP_START=$(ACL_BUILD_ACLMALLOC_HEAP_START) 107 | else 108 | env = 109 | endif 110 | 111 | do_build: prereqs commit-id.cl 112 | # make sure the demo and non-demo versions do not share fasls: 113 | rm -fr nfs *.fasl b.tmp build.out 114 | echo '(dribble "build.out")' >> b.tmp 115 | echo '(setq excl::*break-on-warnings* t)' >> b.tmp 116 | ifdef DEMOWARE 117 | echo '(push :nfs-demo *features*)' >> b.tmp 118 | endif 119 | # The variable NFSLISPBSW specifies byte swap in Lisp instead of machine instr. 120 | ifdef NFSLISPBSW 121 | echo '(push :nfs-lisp-bsw *features*)' >> b.tmp 122 | endif 123 | echo '(load "load.cl")' >> b.tmp 124 | echo '(buildit)' >> b.tmp 125 | echo '(dribble)' >> b.tmp 126 | echo '(exit 0)' >> b.tmp 127 | $(env) $(LISPEXE) +B +cn +s b.tmp -batch 128 | rm -f b.tmp 129 | if test -f nfs.cfg; then cp -p nfs.cfg nfs; fi 130 | rm -fr nfs/system-dlls 131 | if test ! -f nfs/vcredist_$(VCREDIST).exe; then \ 132 | cp -p "$(LISPDIR)/vcredist_$(VCREDIST).exe" nfs/; \ 133 | fi 134 | $(MAKE) -C configure 'LISPDIR=$(LISPDIR)' 135 | 136 | # Forcibly rebuild the configure program 137 | configure: FORCE 138 | rm -fr configure/configure 139 | $(MAKE) -C configure 'LISPDIR=$(LISPDIR)' 140 | 141 | installer-common: FORCE 142 | rm -f nfs/nfs.cfg 143 | rm -fr nfs/configure 144 | cp -pr configure/configure nfs 145 | mkdir -p dists 146 | 147 | EXE = dists/setup-nfs-$(version)$(VER_SUFFIX).exe 148 | DEMOEXE = dists/setup-nfs-$(version)$(VER_SUFFIX)-demo.exe 149 | 150 | ifeq ($(NFSWIDTH),64) 151 | INSTALLDIR = AllegroNFS64 152 | else 153 | INSTALLDIR = AllegroNFS 154 | endif 155 | 156 | COMMON_INSTALLER_OPTIONS = /DINSTALLDIR=$(INSTALLDIR) 157 | 158 | installer: installer-common 159 | $(MAKENSIS) /V1 $(COMMON_INSTALLER_OPTIONS) \ 160 | /DVERSION=$(version)$(VER_SUFFIX) \ 161 | /DVERSION2=$(version)$(VER_SUFFIX) \ 162 | nfs.nsi 163 | ifdef FICODESIGN 164 | $(FICODESIGN) $(EXE) 165 | endif 166 | sha256sum $(EXE) > $(EXE).sha256sum 167 | 168 | installer-demo: installer-common 169 | $(MAKENSIS) /V1 $(COMMON_INSTALLER_OPTIONS) \ 170 | /DNFSDEMO=true \ 171 | /DVERSION="$(version)$(VER_SUFFIX) Demo" \ 172 | /DVERSION2=$(version)$(VER_SUFFIX)-demo \ 173 | nfs.nsi 174 | ifdef FICODESIGN 175 | $(FICODESIGN) $(DEMOEXE) 176 | endif 177 | sha256sum $(DEMOEXE) > $(DEMOEXE).sha256sum 178 | 179 | # Each build runs in a separate make because there are some 180 | # shared dependencies.. and make will merge them .. and we don't 181 | # want that. Specifically, ``installer-common'' will be run once 182 | # instead of twice. 183 | # 184 | # `clean' added to make sure that configure is really rebuilt. There 185 | # was evidence in June of 2011 that this wasn't happening. -Kevin/Elliott 186 | dists: clean check_tag_name 187 | @if grep -q '^(pushnew :nfs-' load.cl && ! grep -q 'nfsd-version.*beta' nfs-common.cl; then \ 188 | echo ERROR: debugging features enabled for production build; \ 189 | exit 1; \ 190 | fi 191 | $(MAKE) $(MFLAGS) dist 192 | $(MAKE) $(MFLAGS) dist-demo 193 | 194 | dist: build installer 195 | 196 | dist-demo: build-demo installer-demo 197 | # Alias 198 | demo-dist: dist-demo 199 | 200 | DEST = ../nfs-outgoing/$(tag_name) 201 | 202 | publish: FORCE 203 | mkdir -p $(DEST) 204 | $(MAKE) $(MFLAGS) NFSWIDTH=64 NFSLISPBSW=yes VER_SUFFIX=-64 publish_aux 205 | $(MAKE) $(MFLAGS) publish_aux 206 | 207 | publish_aux: FORCE 208 | cp -p $(EXE) $(DEST) 209 | cp -p $(EXE).sha256sum $(DEST) 210 | cp -p $(DEMOEXE) $(DEST) 211 | cp -p $(DEMOEXE).sha256sum $(DEST) 212 | 213 | ############################################################################### 214 | # testing 215 | 216 | # Needs the tirpc Cygwin package on Windows 217 | 218 | exe := $(shell test -d c:/ && echo .exe) 219 | 220 | hammer_deps = \ 221 | test/hammernfs-libs/mount_xdr.c \ 222 | test/hammernfs-libs/mount_clnt.c \ 223 | test/hammernfs-libs/nfs_clnt.c \ 224 | test/hammernfs-libs/nfs_xdr.c \ 225 | test/nfs-common.c 226 | 227 | # $@ is the target and $< is the first dependency. 228 | define build_test_program 229 | cc -O -o $@ \ 230 | $(shell uname | grep -q CYGWIN && echo -I/usr/include/tirpc) \ 231 | $< \ 232 | $(hammer_deps) \ 233 | $(shell uname | grep -q CYGWIN && echo -ltirpc) 234 | endef 235 | 236 | hammernfs$(exe): test/hammernfs.c $(hammer_deps) 237 | $(build_test_program) 238 | 239 | test-conn-reset$(exe): test/test-conn-reset.c $(hammer_deps) 240 | $(build_test_program) 241 | 242 | test-big-readdir-udp$(exe): test/test-big-readdir-udp.c $(hammer_deps) 243 | $(build_test_program) 244 | 245 | test-nfs-low$(exe): test/test-nfs-low.c $(hammer_deps) 246 | $(build_test_program) 247 | 248 | perftest: FORCE 249 | test/performance.sh test/performance.log.$(version) 250 | $(LISPEXE) -L test/performance.cl 251 | 252 | testnfs: test/testnfs.c 253 | cc -O -o testnfs test/testnfs.c 254 | 255 | results: FORCE 256 | @prev=; for v in $$(cd results; echo *); do \ 257 | if [ "$$prev" ]; then \ 258 | test/results.cl $$prev $$v; \ 259 | fi; \ 260 | prev=$$v; \ 261 | done 262 | 263 | # The following 3 variables must be set externally to specify 264 | # the current test machine configuration. 265 | LOCAL_TEST_DIR ?= /home/tmp/layer/nfs.test 266 | REMOTE_TEST_DIR ?= /c/tmp/nfs.test 267 | TEST_HOST ?= thunder 268 | TEST_NFSPATH = /net/$(TEST_HOST)/nfs.test 269 | 270 | ###### times for various iterations: 271 | # 1 iteration takes ~75 seconds. 272 | # 240 iterations takes ~5.5 hours. 273 | # 600 iterations takes ~13 hours. 274 | STRESS_ITERATIONS ?= 600 275 | 276 | # Each test gets progressively longer 277 | runtests: testnfs test-nfs-low 278 | date 279 | ./test-nfs-low $(TEST_HOST):/c 280 | # test/misc-tests.sh $(TEST_HOST) /net/$(TEST_HOST)/c 281 | # The above test does not always work because of Win10 permission issues. 282 | ./test/misc-tests.sh $(TEST_HOST) $(TEST_NFSPATH) $(REMOTE_TEST_DIR) 283 | ./testnfs -l $(LOCAL_TEST_DIR) -t $(REMOTE_TEST_DIR) \ 284 | $(TEST_HOST) $(TEST_NFSPATH) 285 | ./test/bigfile-test.sh $(LOCAL_TEST_DIR) $(TEST_NFSPATH) 286 | ./test/stress-test.sh $(LOCAL_TEST_DIR) $(TEST_NFSPATH) \ 287 | $(STRESS_ITERATIONS) 288 | date 289 | 290 | ############################################################################### 291 | # misc 292 | 293 | echo_version: FORCE 294 | @echo $(version) 295 | 296 | clean: FORCE 297 | rm -rf *.out *.fasl */*.fasl *.zip *.tmp nfs *~ .*~ 298 | rm -f gen-nfs-*.cl mount-*.cl sunrpc-common.cl nlm-*.cl nsm-*.cl 299 | rm -f portmap-*.cl hammernfs$(exe) test-conn-reset$(exe) test-big-readdir-udp$(exe) 300 | $(MAKE) -C configure clean 301 | 302 | tags: FORCE 303 | find . -name "*.cl" | xargs etags 304 | 305 | FORCE: 306 | -------------------------------------------------------------------------------- /anfs-version: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env bash 2 | # print the version in nfs-common.cl to stdout 3 | 4 | set -eu 5 | 6 | string="$(grep 'defvar .nfsd-version' nfs-common.cl)" 7 | 8 | if [[ $string =~ nfsd-version..\"([0-9]+)\.([0-9]+)\.([0-9]+)(-(beta[0-9]+))?\" ]] 9 | then 10 | if [ "${BASH_REMATCH[5]-}" ]; then 11 | echo ${BASH_REMATCH[1]}.${BASH_REMATCH[2]}.${BASH_REMATCH[3]}-${BASH_REMATCH[5]} 12 | else 13 | echo ${BASH_REMATCH[1]}.${BASH_REMATCH[2]}.${BASH_REMATCH[3]} 14 | fi 15 | else 16 | echo $0: could not extract version from $* 1>&2 17 | fi 18 | 19 | -------------------------------------------------------------------------------- /attr.cl: -------------------------------------------------------------------------------- 1 | (in-package :user) 2 | 3 | (eval-when (compile) (declaim (optimize (speed 3)))) 4 | 5 | ;; file types 6 | (defconstant *NFNON* 0) 7 | (defconstant *NFREG* 1) 8 | (defconstant *NFDIR* 2) 9 | (defconstant *NFBLK* 3) 10 | (defconstant *NFCHR* 4) 11 | (defconstant *NFLNK* 5) 12 | ;; v3 13 | (defconstant *NFSOCK* 6) 14 | (defconstant *NFFIFO* 7) 15 | 16 | (defstruct nfs-attr 17 | type ;; See defconstants above 18 | mode 19 | nlinks 20 | uid 21 | gid 22 | size 23 | blocksize ;; v2 only 24 | used ;; v3. used disk space in bytes (may be less than filesize in case of sparse files) 25 | rdev ;; we don't support this.. so always unused (i.e., zero) 26 | blocks ;; v2 only 27 | fsid 28 | fileid 29 | atime ;; stored as universal time 30 | mtime ;; stored as universal time 31 | ctime ;; stored as universal time 32 | ) 33 | 34 | 35 | ;; keys are file handles 36 | (defparameter *nfs-attr-cache* (make-hash-table :test #'eq)) 37 | (defparameter *attr-cache-lock* (mp:make-process-lock)) 38 | 39 | (defmacro stat-mode-to-type (mode) 40 | `(ecase (logand ,mode *s-ifmt*) 41 | (#.*s-ifdir* 42 | *NFDIR*) 43 | (#.*s-ifreg* 44 | *NFREG*) 45 | (#o0120000 ;; no *s-iflnk* defined on Windows 46 | *NFLNK*))) 47 | 48 | (defun nfs-stat (fh) 49 | (declare (optimize (speed 3))) 50 | ;;(logit "Collecting fresh attrs for ~a" (fh-pathname fh)) 51 | (multiple-value-bind (mode nlink uid gid size atime mtime ctime) 52 | (unicode-stat (fh-pathname fh)) 53 | (let ((type (stat-mode-to-type mode))) 54 | (if* (eq type *NFDIR*) 55 | then (setf size 512)) 56 | (make-nfs-attr 57 | :type type 58 | :mode mode 59 | :nlinks (if (eq nlink 0) 1 nlink) 60 | :uid uid 61 | :gid gid 62 | :size size 63 | :blocksize 512 64 | :used size 65 | :blocks (howmany size 512) 66 | :fsid (nfs-export-id (fh-export fh)) 67 | :fileid (fh-file-id fh) 68 | :atime atime 69 | :mtime mtime 70 | :ctime ctime)))) 71 | 72 | (defstruct nfs-attr-cache 73 | attr 74 | expiration ;; internal-real-time 75 | ) 76 | 77 | (defun lookup-attr (fh) 78 | (mp:with-process-lock (*attr-cache-lock*) 79 | (let ((attr-cache (gethash fh *nfs-attr-cache*)) 80 | (debug nil)) 81 | (when debug 82 | (logit "Looking attributes for ~a~%" (fh-pathname fh))) 83 | (if* attr-cache 84 | then ;; We have a cached entry. Check its expiration 85 | (let ((now (excl::cl-internal-real-time))) 86 | (if* (>= now (nfs-attr-cache-expiration attr-cache)) 87 | then ;; It expired. Refresh the attributes and return. 88 | (when debug 89 | (logit "Prior cached attributes have expired. Collecting fresh data.~%")) 90 | (let ((attr (nfs-stat fh))) 91 | (setf (nfs-attr-cache-attr attr-cache) attr) 92 | (setf (nfs-attr-cache-expiration attr-cache) (+ now *attr-cache-reap-time*)) 93 | ;; Good to go 94 | attr) 95 | else ;; Not expired. Use the cached attributes 96 | (when debug 97 | (logit "Using cached attrs~%")) 98 | (nfs-attr-cache-attr attr-cache))) 99 | else ;; No cached entry. Make one. 100 | (when debug 101 | (logit "No cached attributes found. Collecting fresh data.~%")) 102 | (let ((attr (nfs-stat fh))) 103 | (setf (gethash fh *nfs-attr-cache*) 104 | (make-nfs-attr-cache 105 | :attr attr 106 | :expiration (+ (excl::cl-internal-real-time) *attr-cache-reap-time*))) 107 | 108 | ;; Return new attrs 109 | attr))))) 110 | 111 | ;; list of size, mtime, ctime 112 | (defun get-pre-op-attrs (fh) 113 | (let ((attrs (lookup-attr fh))) 114 | (list (nfs-attr-size attrs) 115 | (nfs-attr-mtime attrs) 116 | (nfs-attr-ctime attrs)))) 117 | 118 | (defun pre-op-attrs-ctime (pre-op-attrs) 119 | (third pre-op-attrs)) 120 | 121 | 122 | (defun dump-attr-cache () 123 | (mp:with-process-lock (*attr-cache-lock*) 124 | (maphash #'(lambda (key value) 125 | (format t "~S -> ~S~%" key value)) 126 | *nfs-attr-cache*))) 127 | 128 | (defun attr-cache-reaper () 129 | (loop 130 | (sleep (max *attr-cache-reap-time* 1)) 131 | (reap-attr-cache))) 132 | 133 | ;;; XXX -- might want to make sure that directories 134 | ;;; have their a/m/c-times updates before uncaching.. in case 135 | ;;; operations were done in a cached way. need to think about 136 | ;;; this more. 137 | (defun reap-attr-cache () 138 | (mp:with-process-lock (*attr-cache-lock*) 139 | (let ((now (excl::cl-internal-real-time))) 140 | 141 | (maphash 142 | #'(lambda (key attr-cache) 143 | (when (>= now (nfs-attr-cache-expiration attr-cache)) 144 | ;; Expired entry. Remove it. 145 | (remhash key *nfs-attr-cache*))) 146 | *nfs-attr-cache*)))) 147 | 148 | ;; XXX -- callers to this function should make sure they've 149 | ;; written out any cached attr updates before calling. 150 | (defun uncache-attr (fh) 151 | (mp:with-process-lock (*attr-cache-lock*) 152 | (remhash fh *nfs-attr-cache*))) 153 | 154 | 155 | ;; used when reading from a file or directory 156 | (defun update-attr-atime (fh &optional (when (get-universal-time))) 157 | (let ((attr (lookup-attr fh))) 158 | (setf (nfs-attr-atime attr) when) 159 | attr)) 160 | 161 | ;; updates ctime as well. 162 | ;; used by directory modifying functions which don't care about size. 163 | (defun update-atime-and-mtime (fh &optional (when (get-universal-time))) 164 | (let ((attr (lookup-attr fh))) 165 | (setf (nfs-attr-atime attr) when) 166 | (setf (nfs-attr-mtime attr) when) 167 | (setf (nfs-attr-ctime attr) when) 168 | attr)) 169 | 170 | (ff:def-foreign-call (sys-futime "_futime") ((fd :int) (utimbuf (* :void)))) 171 | 172 | ;; used by file modification functions. (i.e nfsd-write(3)) 173 | (defun update-attr-times-and-size (stream fh set-mtime) 174 | (if (not (open-stream-p stream)) 175 | (error "Something passed a closed stream to update-attr-times-and-size")) 176 | (if set-mtime 177 | (sys-futime (excl.osi::stream-to-fd stream) 0)) 178 | (let ((attr (update-atime-and-mtime fh)) 179 | (pos (file-position stream))) 180 | (when (> pos (nfs-attr-size attr)) 181 | (setf (nfs-attr-size attr) pos) 182 | (setf (nfs-attr-used attr) pos) 183 | (setf (nfs-attr-blocks attr) (howmany pos 512))))) 184 | 185 | (defun set-cached-file-size (fh size) 186 | (let ((attr (lookup-attr fh))) 187 | (setf (nfs-attr-size attr) size) 188 | (setf (nfs-attr-used attr) size) 189 | (setf (nfs-attr-blocks attr) (howmany size 512)) 190 | (setf (nfs-attr-ctime attr) (get-universal-time)) 191 | size)) 192 | 193 | (defun set-cached-file-atime (fh atime) 194 | (let ((attr (lookup-attr fh))) 195 | (setf (nfs-attr-atime attr) atime) 196 | (setf (nfs-attr-ctime attr) (get-universal-time)) 197 | atime)) 198 | 199 | (defun set-cached-file-mtime (fh mtime) 200 | (let ((attr (lookup-attr fh))) 201 | (setf (nfs-attr-mtime attr) mtime) 202 | (setf (nfs-attr-ctime attr) (get-universal-time)) 203 | mtime)) 204 | 205 | (defun incf-cached-nlinks (fh) 206 | (incf (nfs-attr-nlinks (lookup-attr fh)))) 207 | -------------------------------------------------------------------------------- /bin/verify_modules.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | switch_to_branch() 4 | { 5 | # $1 = remote (e.g., origin) 6 | # $2 = target branch (e.g., acl82) 7 | local remote=$1 8 | local branch=${2-} 9 | git fetch $remote 10 | if test -n "${branch}"; then 11 | if git_branch_exists_p $branch; then 12 | # already exists as a local branch, get on it: 13 | git checkout -q $branch 14 | elif git_remote_exists_p $remote/$branch; then 15 | # no remote tracking branch, create it 16 | git checkout -q -b $branch $remote/$branch 17 | else 18 | # does not exist 19 | echo ERROR: $remote/$branch does not exist. 20 | exit 1 21 | fi 22 | fi 23 | } 24 | 25 | git_branch_exists_p() 26 | { 27 | git show-ref --quiet --verify -- "refs/heads/$1" 28 | } 29 | 30 | git_remote_exists_p() 31 | { 32 | git show-ref --quiet --verify -- "refs/remotes/$1" 33 | } 34 | 35 | compute_origin_base_url() 36 | { 37 | dirname `git config --get remote.origin.url` 38 | } 39 | 40 | 41 | back=$(pwd) 42 | for thing in $*; do 43 | if test "$thing" = "."; then 44 | branch_check_only=xxx 45 | else 46 | branch_check_only= 47 | fi 48 | 49 | branch=`echo $thing | sed 's/\(.*\):\(.*\)/\2/'` 50 | if test -z "$branch_check_only"; then 51 | repo=`echo $thing | sed 's/\(.*\):\(.*\)/\1/'` 52 | if test ! -d $repo; then 53 | echo "checking out $repo..." 54 | url=`compute_origin_base_url`/$repo 55 | git clone -q $url $repo 56 | fi 57 | fi 58 | 59 | cd $repo 60 | 61 | current="`git branch | awk '/^* / { print $2; }'`" 62 | if test "$current" != "$branch"; then 63 | echo "moving $repo onto $branch branch..." 64 | switch_to_branch origin $branch 65 | fi 66 | 67 | cd $back 68 | done 69 | -------------------------------------------------------------------------------- /bswap.cl: -------------------------------------------------------------------------------- 1 | 2 | (in-package :comp) 3 | 4 | (def-i386-instr bswap-eax iq-asm-comment nil 5 | (iq-ia-hex nil #x0f #xc8)) 6 | 7 | (def-i386-instr bswap-ecx iq-asm-comment nil 8 | (iq-ia-hex nil #x0f #xc9)) 9 | 10 | (def-i386-instr bswap-ebx iq-asm-comment nil 11 | (iq-ia-hex nil #x0f #xcb)) 12 | 13 | (def-i386-instr bswap-edx iq-asm-comment nil 14 | (iq-ia-hex nil #x0f #xca)) 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /config-defs.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; USER 6 | 7 | (in-package :user) 8 | 9 | (defvar *nfs-debug* nil) 10 | (defvar *nfs-gc-debug* nil) 11 | (defvar *nfs-debug-timings* nil) 12 | (defvar *nfs-set-mtime-on-write* nil) 13 | (defvar *nfs-debug-filter* #x0fffffff) 14 | (defvar *log-file* "sys:nfsdebug-~D.txt") 15 | 16 | ;; Needs UI [rfe8202] 17 | (defvar *executable-types* '("exe" "com" "bat")) 18 | 19 | (defvar *log-rotation-file-size* 0) 20 | (defvar *log-rotation-file-count* 1) 21 | (defvar *log-rotation-current-count* 0) 22 | 23 | (defvar *kilobyte* 1024) 24 | (defvar *megabyte* (* *kilobyte* *kilobyte*)) 25 | (defvar *gigabyte* (* *megabyte* *kilobyte*)) 26 | (defvar *terabyte* (* *gigabyte* *kilobyte*)) 27 | 28 | (defvar *log-rotation-file-size-magnitude* *megabyte*) 29 | 30 | (defvar *nfs-dircache-update-interval* 2) 31 | 32 | (defvar *open-file-reap-time* 2) 33 | 34 | ;; Value should always be larger than *open-file-reap-time*. This is 35 | ;; because the open file reaper needs the cached stat information when 36 | ;; closing a file that was opened for writing, so that it can update the 37 | ;; atime/mtime of the file. 38 | (defvar *attr-cache-reap-time* 5) 39 | 40 | (defvar *disable-persistent-fhandles* nil) 41 | 42 | (defvar *enable-32bit-file-id-truncate* nil) 43 | 44 | (defun make-log-rotation-name (index) 45 | "Appends a version onto the logfile name." 46 | (format nil *log-file* index)) 47 | 48 | (defun find-latest-log-file () 49 | (let ((latest (make-log-rotation-name 0))) 50 | ;; Ensure the file exists. 51 | (unless (probe-file latest) 52 | (with-open-file (f latest 53 | :direction :output 54 | :if-does-not-exist :create))) 55 | (loop for i from 0 to (1- *log-rotation-file-count*) 56 | when (probe-file (make-log-rotation-name i)) 57 | do (let ((newest (make-log-rotation-name i))) 58 | (when (< (file-write-date latest) 59 | (file-write-date newest)) 60 | (setf latest newest 61 | *log-rotation-current-count* i)))) 62 | latest)) 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | ;; PORTMAP 66 | 67 | (defpackage :xdr 68 | (:use :lisp :excl)) 69 | 70 | (defpackage :portmap 71 | (:use :lisp :excl :xdr) 72 | (:export #:*portmap-debug* 73 | #:*use-system-portmapper*)) 74 | 75 | (in-package :portmap) 76 | 77 | (defvar *portmap-debug* nil) 78 | (defvar *use-system-portmapper* :auto) 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;; MOUNT 82 | 83 | (defpackage :mount 84 | (:use :lisp :excl :xdr) 85 | (:export #:*mountd-debug* 86 | #:*mountd-port-number* 87 | #:*showmount-disabled*)) 88 | 89 | (in-package :mount) 90 | 91 | (defvar *mountd-debug* nil) 92 | (defvar *mountd-port-number* nil) 93 | (defvar *showmount-disabled* nil) 94 | 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | ;; NSM 97 | 98 | (defpackage :nsm 99 | (:use :lisp :excl :xdr) 100 | (:export #:*nsm-debug* 101 | #:*nsm-port*)) 102 | 103 | (in-package :nsm) 104 | 105 | (defvar *nsm-debug* nil) 106 | (defvar *nsm-port* nil) 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | ;; NSM 110 | 111 | (defpackage :nlm 112 | (:use :lisp :excl :xdr) 113 | (:export #:*nlm-debug* 114 | #:*nlm-port*)) 115 | 116 | (in-package :nlm) 117 | 118 | (defvar *nlm-debug* nil) 119 | (defvar *nlm-port* nil) 120 | -------------------------------------------------------------------------------- /configure.cl: -------------------------------------------------------------------------------- 1 | (in-package :user) 2 | 3 | (defparameter *configfile* nil) 4 | 5 | (defun read-nfs-cfg (configfile) 6 | (let ((host-lists (make-hash-table :test #'equalp)) 7 | (user-lists (make-hash-table :test #'equalp)) 8 | config cmd name) 9 | (prepare-exports) 10 | (setf config (read-from-string (file-contents configfile))) 11 | (dolist (entry config) 12 | (when (not (listp entry)) 13 | (error "Invalid configuration entry: ~S~%" entry)) 14 | (setf cmd (pop entry)) 15 | (case cmd 16 | (define-host-list 17 | (setf name (pop entry)) 18 | (let ((res '()) temp) 19 | (dolist (thing entry) 20 | (if* (setq temp (ignore-errors (parse-addr thing))) 21 | then (push temp res) 22 | else (logit "Warning: could not resolve host ~s~%" thing))) 23 | (setf (gethash name host-lists) res))) 24 | (define-user-list 25 | (setf name (pop entry)) 26 | (setf (gethash name user-lists) entry)) 27 | (define-export 28 | (setf entry (append entry (list :host-lists host-lists 29 | :user-lists user-lists))) 30 | (apply #'define-export entry)) 31 | (t 32 | (set cmd (pop entry))))) 33 | (finalize-exports))) 34 | 35 | -------------------------------------------------------------------------------- /configure/.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | autoloads.out 3 | *.build-dribble 4 | configure 5 | -------------------------------------------------------------------------------- /configure/Makefile: -------------------------------------------------------------------------------- 1 | 2 | PROGRAM_FILES = /c/Program Files 3 | 4 | DO_MAKEFILE_LOCAL := $(shell if test -f ../Makefile.local; then echo yes; fi) 5 | 6 | ifeq ($(DO_MAKEFILE_LOCAL),yes) 7 | include ../Makefile.local 8 | endif 9 | 10 | ifndef LISPDIR 11 | LISPDIR = /c/acl100.patched 12 | endif 13 | 14 | ifeq ($(LISPDIR),/c/acl82.patched) 15 | ALLEGRO=$(LISPDIR)/allegro 16 | else 17 | ALLEGRO=$(LISPDIR)/mlisp 18 | endif 19 | 20 | # Worst directory name ever 21 | ifndef MT 22 | NEWSDK = $(shell if test -d "/c/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/bin"; then echo yes; else echo no; fi) 23 | ifeq ($(NEWSDK),yes) 24 | MT="/c/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/bin/mt.exe" 25 | else 26 | MT="/c/Program Files/Microsoft Platform SDK for Windows Server 2003 R2/Bin/mt.exe" 27 | endif 28 | endif 29 | 30 | build: configure/configure.exe configure.exe.manifest 31 | $(MT) -manifest configure.exe.manifest -outputresource:configure/configure.exe 32 | 33 | configure/configure.exe: 34 | $(ALLEGRO) +B +cn -L buildit.cl 35 | 36 | clean: 37 | rm -fr *.fasl configure *.build-dribble *.out 38 | -------------------------------------------------------------------------------- /configure/buildit.cl: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-user) 3 | 4 | (setq excl::*break-on-warnings* t) 5 | 6 | #+(version>= 9 0) 7 | (eval-when (compile eval load) (require :ide)) 8 | 9 | (defun buildit () 10 | #+(version>= 9 0) 11 | (setq *print-readably* nil) 12 | 13 | (ide.project:build-project 14 | (ide.project:load-project "configure.lpr") 15 | :distribution-directory "configure/" 16 | :replace-if-exists t 17 | :increment-build-number nil) 18 | 19 | #+(version= 8 2) 20 | (dolist (p mp:*all-processes*) 21 | (format t "; killing ~a...~%" p) 22 | (when (not (eq mp:*current-process* p)) 23 | (mp:process-kill p))) 24 | 25 | (exit 0)) 26 | 27 | #+(version= 8 2) 28 | (push 'buildit ide:*ide-startup-hook*) 29 | 30 | #+(version>= 9 0) 31 | (buildit) 32 | -------------------------------------------------------------------------------- /configure/configure.exe.manifest: -------------------------------------------------------------------------------- 1 | 2 | 3 | 7 | 8 | 9 | 10 | 11 | 12 | 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /configure/configure.lpr: -------------------------------------------------------------------------------- 1 | ;; -*- lisp-version: "10.1 [32-bit Windows] (Aug 18, 2020 16:51)"; -*- 2 | 3 | (in-package :cg-user) 4 | 5 | (define-project :name :configure 6 | :modules (list (make-instance 'module :name "../config-defs") 7 | (make-instance 'module :name "../xdr") 8 | (make-instance 'module :name "../sunrpc-common") 9 | (make-instance 'module :name "../portmap-common") 10 | (make-instance 'module :name "../mount-common") 11 | (make-instance 'module :name "../nsm-common") 12 | (make-instance 'module :name "../nlm-common") 13 | (make-instance 'module :name "../gen-nfs-common") 14 | (make-instance 'module :name "../nfs-common") 15 | (make-instance 'module :name "../nfs-shared") 16 | (make-instance 'module :name "../sunrpc") 17 | (make-instance 'module :name "../portmap-client") 18 | (make-instance 'module :name "nfs-server-io") 19 | (make-instance 'module :name "../directory-tree") 20 | (make-instance 'module :name "export") 21 | (make-instance 'module :name "../ipaddr") 22 | (make-instance 'form-module :name "configform" :finder-function 23 | 'configform :has-pixmap-file nil) 24 | (make-instance 'form-module :name "help-form" :finder-function 25 | 'help-form :has-pixmap-file nil)) 26 | :projects nil 27 | :libraries nil 28 | :editable-files nil 29 | :distributed-files (list "../doc/configuration.txt") 30 | :internally-loaded-files nil 31 | :project-package-name :common-graphics-user 32 | :main-form 'configform 33 | :compilation-unit t 34 | :concatenate-project-fasls nil 35 | :verbose nil 36 | :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-stream :cg.button :cg.caret 37 | :cg.check-box :cg.clipboard :cg.clipboard-stack 38 | :cg.clipboard.pixmap :cg.combo-box :cg.common-control :cg.comtab 39 | :cg.dialog-item :cg.directory-dialog-os :cg.editable-text 40 | :cg.group-box :cg.icon :cg.item-list :cg.keyboard-shortcuts 41 | :cg.lisp-widget :cg.message-dialog :cg.multi-line-editable-text 42 | :cg.os-widget :cg.picture-widget :cg.pixmap :cg.pixmap-widget 43 | :cg.pixmap.file-io :cg.scrolling-static-text :cg.static-text 44 | :cg.string-dialog :cg.tab-control :cg.text-edit-pane 45 | :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget 46 | :cg.tooltip :cg.utility-dialog) 47 | :splash-file-module (make-instance 'build-module :name "") 48 | :icon-file-module (make-instance 'build-module :name "../nfs.ico") 49 | :include-flags (list :local-name-info) 50 | :build-flags (list :purify) 51 | :autoload-warning t 52 | :full-recompile-for-runtime-conditionalizations nil 53 | :include-manifest-file-for-visual-styles t 54 | :default-command-line-arguments "+R +t \"Initializing\"" 55 | :additional-build-lisp-image-arguments (list :read-init-files nil) 56 | :old-space-size 256000 57 | :new-space-size 6144 58 | :runtime-build-option :standard 59 | :build-number 1 60 | :run-with-console nil 61 | :project-file-version-info nil 62 | :on-initialization 'init-func 63 | :default-error-handler-for-delivery 'report-unexpected-error-and-exit 64 | :on-restart 'do-default-restart) 65 | 66 | ;; End of Project Definition 67 | -------------------------------------------------------------------------------- /configure/export.cl: -------------------------------------------------------------------------------- 1 | (in-package :cg-user) 2 | 3 | (defparameter *exports* nil) 4 | 5 | (defstruct nfs-export 6 | index 7 | name 8 | path 9 | uid 10 | gid 11 | umask 12 | set-mode-bits 13 | hosts-allow 14 | rw-users 15 | ro-users) 16 | 17 | (defun define-export (&key name path (uid 9999) (gid 9999) 18 | (umask 0) (set-mode-bits 0) 19 | hosts-allow rw-users ro-users) 20 | (when (null name) 21 | (error ":name must be specified for define-export")) 22 | (when (null path) 23 | (error ":path must be specified for define-export")) 24 | (if (and hosts-allow (not (listp hosts-allow))) 25 | (setf hosts-allow (list hosts-allow))) 26 | (if (and rw-users (not (listp rw-users))) 27 | (setf rw-users (list rw-users))) 28 | (if (and ro-users (not (listp ro-users))) 29 | (setf ro-users (list ro-users))) 30 | (setf *exports* 31 | (append *exports* 32 | (list 33 | (make-nfs-export 34 | :index (length *exports*) 35 | :name name 36 | :path (user::cleanup-dir path) 37 | :uid uid 38 | :gid gid 39 | :umask umask 40 | :set-mode-bits set-mode-bits 41 | :hosts-allow hosts-allow 42 | :rw-users rw-users 43 | :ro-users ro-users))))) 44 | 45 | (defun find-export (name) 46 | (setf name (directory-tree:canonicalize-path name)) 47 | 48 | (dolist (exp *exports*) 49 | (when (equalp (directory-tree:canonicalize-path (nfs-export-name exp)) name) 50 | (return exp)))) 51 | -------------------------------------------------------------------------------- /configure/help-form.bil: -------------------------------------------------------------------------------- 1 | ;;; Define :help-form 2 | 3 | (in-package :common-graphics-user) 4 | 5 | ;; The finder-function, which returns the window if it already 6 | ;; exists, and otherwise creates and returns it. 7 | ;; Call this function if you need only one copy of this window, 8 | ;; and that window is a non-owned top-level window. 9 | (defun help-form () (find-or-make-application-window :help-form 'make-help-form)) 10 | 11 | ;; The maker-function, which always creates a new window. 12 | ;; Call this function if you need more than one copy, 13 | ;; or the single copy should have a parent or owner window. 14 | ;; (Pass :owner to this function; :parent is for compatibility.) 15 | (defun make-help-form 16 | (&key parent (owner (or parent (screen *system*))) exterior 17 | (interior (make-box 297 150 977 732)) (name :help-form) 18 | (title "Allegro NFS Server Documentation") (border :frame) (child-p t) form-p) 19 | (let ((owner 20 | (make-window name :owner owner 21 | :class 'dialog 22 | :child-p child-p 23 | :exterior exterior 24 | :interior interior 25 | :border border 26 | :close-button t 27 | :cursor-name :arrow-cursor 28 | :font (make-font-ex :swiss "MS Sans Serif / ANSI" 11) 29 | :form-state :shrunk 30 | :maximize-button t 31 | :minimize-button t 32 | :name :help-form 33 | :pop-up nil 34 | :resizable t 35 | :scrollbars nil 36 | :state :normal 37 | :system-menu t 38 | :title title 39 | :title-bar t 40 | :dialog-items (make-help-form-widgets) 41 | :form-p form-p 42 | :form-package-name nil))) 43 | owner)) 44 | 45 | (defun make-help-form-widgets () 46 | (list (make-instance 'multi-line-editable-text :font 47 | (make-font-ex :modern "Courier / ANSI" 13) :height 527 :left 20 48 | :name :text :read-only t :top 17 :value "" :width 640) 49 | (make-instance 'button :font (make-font-ex nil "Tahoma / ANSI" 11) :left 288 50 | :name :close-help-button :on-change 51 | 'help-form-close-help-button-on-change :title "Close" :top 552))) 52 | -------------------------------------------------------------------------------- /configure/help-form.cl: -------------------------------------------------------------------------------- 1 | ;; Code for the dialog :help-form 2 | 3 | (in-package :common-graphics-user) 4 | 5 | (defun do-help (thing) 6 | (declare (ignore thing)) 7 | (let ((form (help-form)) 8 | (textfile (merge-pathnames "configuration.txt" *progpath*))) 9 | ;; for testing in development 10 | (if (not (probe-file textfile)) 11 | (setf textfile "configuration.txt")) 12 | (setf (value (my-find-component :text form)) (file-contents textfile)))) 13 | 14 | 15 | (defun help-form-close-help-button-on-change (widget 16 | new-value 17 | old-value) 18 | (declare (ignore-if-unused widget new-value old-value)) 19 | (user-close (parent widget)) 20 | t) 21 | -------------------------------------------------------------------------------- /configure/nfs-server-io.cl: -------------------------------------------------------------------------------- 1 | (in-package :user) 2 | 3 | ;; $Id: nfs-server-io.cl,v 1.4 2006/05/11 21:58:59 dancy Exp $ 4 | 5 | ;; returns nil if no answer 6 | (defun get-nfs-server-config-file () 7 | (ignore-errors 8 | (sunrpc:with-rpc-client (cli "127.0.01" #.gen-nfs:*nfs-program* 2 :udp) 9 | (sunrpc:callrpc cli 100 nil nil :outproc #'xdr:xdr-string)))) 10 | 11 | (defun reload-nfs-server-config () 12 | (ignore-errors 13 | (sunrpc:with-rpc-client (cli "127.0.01" #.gen-nfs:*nfs-program* 2 :udp) 14 | (= 1 (sunrpc:callrpc cli 101 nil nil :outproc #'xdr:xdr-unsigned-int))))) 15 | -------------------------------------------------------------------------------- /dir.cl: -------------------------------------------------------------------------------- 1 | (in-package :user) 2 | 3 | ;; Directory caching functions. 4 | 5 | ;; We must keep directory information cached forever because readdir 6 | ;; cookies are expected (by NFS clients, particularly Solaris) to 7 | ;; be valid forever. 8 | 9 | (defparameter *nfs-dircache* (make-hash-table :test #'eq)) ;; Key is fhandle, value is dircache struct 10 | (defparameter *nfs-dircachelock* (mp:make-process-lock)) 11 | 12 | (defparameter *dir-id* 0) 13 | 14 | (defstruct dircache 15 | (entries (make-array 0) :type simple-vector) 16 | (mtime (excl::cl-internal-real-time) :type fixnum) 17 | 18 | ;; This is a list of indices of dircache-entries which are 19 | ;; available for reuse. It is added to by update-dircache and 20 | ;; nfs-remove-file-from-dir and reduced by add-to-dircache. 21 | (free-slots nil :type list) 22 | 23 | (id (incf *dir-id*))) 24 | 25 | ;; Returns a list or array of basenames. 26 | ;; called by nfs-lookup-dir. 27 | (defun augmented-directory (dir as-array) 28 | (declare (optimize (speed 3) (safety 0)) 29 | (simple-string dir)) 30 | (if (char/= (schar dir (1- (length dir))) #\\) 31 | (setf dir (concatenate 'string dir "\\"))) 32 | (let ((res (unicode-directory dir))) 33 | (if* as-array 34 | then (let ((arr (make-array (length res))) 35 | (n 0)) 36 | (declare (fixnum n)) 37 | (dolist (entry res) 38 | (setf (aref arr n) entry) 39 | (incf n)) 40 | arr) 41 | else res))) 42 | 43 | (defun add-to-dircache-tail (dc files) 44 | (declare (optimize (speed 3) (safety 0)) 45 | (list files)) 46 | (let* ((old (dircache-entries dc)) 47 | (len (length old)) 48 | (pos len) 49 | (new (make-array (the fixnum (+ len (length files)))))) 50 | (declare (fixnum len pos)) 51 | ;; copy old entries 52 | (dotimes (n len) 53 | (setf (aref new n) (aref old n))) 54 | ;; Add new entries 55 | (dolist (file files) 56 | (setf (aref new pos) file) 57 | (incf pos)) 58 | (setf (dircache-entries dc) new))) 59 | 60 | (defun add-to-dircache (dc files) 61 | (declare (optimize (speed 3) (safety 0)) 62 | (list files)) 63 | (let ((entries (dircache-entries dc))) 64 | (loop 65 | (let ((file (pop files))) 66 | (if (null file) ;; done 67 | (return)) 68 | (let ((slot (pop (dircache-free-slots dc)))) 69 | (if* slot 70 | then (setf (aref entries slot) file) 71 | #+ignore 72 | (format t " added ~a to slot ~a~%" file slot) 73 | else ;; ran out of free slots. Add remaining files to end 74 | #+ignore 75 | (format t " adding ~a to end.~%" (cons file files)) 76 | (add-to-dircache-tail dc (cons file files)) 77 | (return))))))) 78 | 79 | 80 | ;; Look for entries in the DC which are not in CURRENT-FILENAMES. 81 | ;; These are files which disappeared since the last time we looked at 82 | ;; this directory. The return value is undefined. 83 | (defun update-dircache-remove-missing-files (dc current-filenames) 84 | (declare (optimize speed (safety 0))) 85 | 86 | (let ((cached-entries (dircache-entries dc)) 87 | (current-filenames-hash (make-hash-table 88 | :test #'equalp 89 | :size (length current-filenames) 90 | :values nil))) 91 | ;; Populate the hash table of current filenames 92 | (dolist (filename current-filenames) 93 | (puthash-key filename current-filenames-hash)) 94 | 95 | ;; Iterate over cached entries and look for ones that are not 96 | ;; in current-filenames. 97 | (dotimes (n (length cached-entries)) 98 | (let ((entry (aref cached-entries n))) 99 | (if* (and entry (not (gethash entry current-filenames-hash))) 100 | then (setf (aref cached-entries n) nil) 101 | #+ignore 102 | (format t " removed ~a from slot ~a~%" entry n) 103 | (push n (dircache-free-slots dc))))))) 104 | 105 | ;; Look for and cache filenames from CURRENT-FILENAMES which are 106 | ;; not cached in DC. The return value is undefined. 107 | (defun update-dircache-add-missing-files (dc current-filenames) 108 | (declare (optimize speed (safety 0))) 109 | 110 | (let* ((cached-entries (dircache-entries dc)) 111 | (cached-entries-hash (make-hash-table 112 | :test #'equalp 113 | :size (length cached-entries) 114 | :values nil)) 115 | new-filenames) 116 | ;; Populate the hash table of cached filenames 117 | (loop for entry in-sequence cached-entries 118 | do (puthash-key entry cached-entries-hash)) 119 | 120 | ;; Iterate over current filenames looking for 121 | ;; any which have not yet been cached. 122 | (dolist (filename current-filenames) 123 | (when (not (gethash filename cached-entries-hash)) 124 | ;; No cache hit. Add it to the list of files 125 | ;; to add to the cache. 126 | (push filename new-filenames))) 127 | 128 | (when new-filenames 129 | ;; Now add the new files to the cache 130 | (add-to-dircache dc new-filenames)))) 131 | 132 | ;; Updates dircache DC by removing cached entries which no longer 133 | ;; exist in the directory and adding new cached entries for files 134 | ;; which showed up in the directory since the last update. 135 | (defun update-dircache (path dc) 136 | (declare (optimize speed (safety 0))) 137 | #+ignore 138 | (format t "update-dircache.~%") 139 | 140 | (let ((current-filenames (augmented-directory path nil))) 141 | 142 | (update-dircache-remove-missing-files dc current-filenames) 143 | (update-dircache-add-missing-files dc current-filenames) 144 | 145 | ;; Update timestamp 146 | (setf (dircache-mtime dc) (excl::cl-internal-real-time)))) 147 | 148 | ;; Called by: 149 | ;; nfs-add-file-to-dir, :operator 150 | ;; nfs-remove-file-from-dir, :operator 151 | ;; add-direntries, :operator 152 | (defun nfs-lookup-dir (fh create) 153 | (declare (optimize (speed 3))) 154 | (mp:with-process-lock (*nfs-dircachelock*) 155 | (let ((dc (gethash fh *nfs-dircache*)) 156 | (debug nil)) 157 | (when debug 158 | (logit "nfs-lookup-dir for ~a~%" (fh-pathname fh))) 159 | 160 | (if* (null dc) 161 | then (when (not create) 162 | (when debug 163 | (logit "No cache hit and not in create mode. Returning nil.~%")) 164 | (return-from nfs-lookup-dir)) 165 | (when debug 166 | (logit "No cache hit. Preparing a new cache entry.~%")) 167 | (let ((path (fh-pathname fh))) 168 | (setf dc (make-dircache :entries (augmented-directory path t))) 169 | (setf (gethash fh *nfs-dircache*) dc) 170 | (values (dircache-entries dc) dc)) 171 | else (when debug 172 | (logit "Cache hit.~%")) 173 | (when (>= (the fixnum 174 | (- (the fixnum (excl::cl-internal-real-time)) 175 | (dircache-mtime dc))) 176 | (the fixnum *nfs-dircache-update-interval*)) 177 | (when debug 178 | (logit "Cached information has expired. Refreshing.~%")) 179 | (update-dircache (fh-pathname fh) dc)) 180 | (values (dircache-entries dc) dc))))) 181 | 182 | ;; Called by link, rename, mkdir, create(3) procs. 183 | ;;; doesn't add duplicates 184 | (defun nfs-add-file-to-dir (file dirfh) 185 | (sanity-check-filename file :create) 186 | (mp:with-process-lock (*nfs-dircachelock*) 187 | (multiple-value-bind (entries dc) 188 | (nfs-lookup-dir dirfh nil) 189 | ;; Don't add duplicates 190 | (when (and dc (not (find file entries :test #'equalp))) 191 | (add-to-dircache dc (list file)))))) 192 | 193 | ;; Called by rename, rmdir, and remove procs. 194 | (defun nfs-remove-file-from-dir (file dirfh) 195 | (sanity-check-filename file :lookup) 196 | (mp:with-process-lock (*nfs-dircachelock*) 197 | (multiple-value-bind (entries dc) 198 | (nfs-lookup-dir dirfh nil) 199 | (when dc 200 | (let ((pos (position file entries :test #'equalp))) 201 | (when pos 202 | (setf (aref entries pos) nil) 203 | (push pos (dircache-free-slots dc)))))))) 204 | -------------------------------------------------------------------------------- /directory-tree.cl: -------------------------------------------------------------------------------- 1 | ;; This file implements a tree of nodes, each of which may contain a piece of 2 | ;; data. The tree starts with an unnamed root node. Children of a node are 3 | ;; addressed by name. 4 | 5 | ;; A path to a node in the tree can be specified as a list of strings or as a 6 | ;; single string which will be parsed into a list of strings. 7 | 8 | (defpackage :directory-tree 9 | (:use :cl :excl) 10 | (:export 11 | #:make-directory-tree 12 | #:insert-directory-tree 13 | #:map-directory-tree 14 | #:find-nearest-data 15 | #:find-data 16 | #:canonicalize-path 17 | )) 18 | 19 | (in-package :directory-tree) 20 | 21 | (defstruct node 22 | name ;; a string, or nil for the root node 23 | data ;; Any Lisp object. nil indicates no data. 24 | children ;; alist mapping from string to node. 25 | parent ;; backlink to parent node. Will be nil for the root node 26 | ) 27 | 28 | ;; Exported 29 | (defun make-directory-tree () 30 | ;; Return the root node 31 | (make-node)) 32 | 33 | ;; Exported 34 | ;; Inserts/updates DATA at location PATH in the directory tree rooted at NODE, 35 | ;; creating intermediate nodes as needed. 36 | ;; Returns DATA. 37 | (defmethod insert-directory-tree ((node node) (path list) data) 38 | (multiple-value-bind (node path) 39 | (search-directory-tree node path) 40 | ;; Add new nodes for the remaining path components. 41 | (dolist (child-name path) 42 | (setf node (add-child node child-name))) 43 | 44 | (setf (node-data node) data) 45 | 46 | data)) 47 | 48 | ;; Exported 49 | (defmethod insert-directory-tree ((node node) (path string) data) 50 | (insert-directory-tree node (parse-directory-path path) data)) 51 | 52 | ;; Exported 53 | ;; CALLBACK will be called once for each node in the tree rooted at NODE, for 54 | ;; each node that has non-nil data. CALLBACK will be passed two arguments: 55 | ;; 1) The canonical node path (a string starting with a slash) 56 | ;; 2) The node data 57 | (defun map-directory-tree (node callback) 58 | (declare (dynamic-extent callback)) 59 | (map-directory-tree-1 node "/" callback)) 60 | 61 | ;; Exported 62 | ;; Finds the deepest node along PATH which has non-nil data. 63 | ;; If such a node is found, returns 64 | ;; 1) The node data 65 | ;; 2) A string represending the remainder of PATH which is below the selected 66 | ;; node. This will be nil if PATH matches a non-nil data node exactly. 67 | ;; Otherwise returns nil. 68 | (defun find-nearest-data (node path) 69 | (multiple-value-bind (node tail) 70 | (search-directory-tree node path) 71 | 72 | ;; Now walk back up the tree until we meet a node with 73 | ;; data 74 | (while (and node (null (node-data node))) 75 | ;; We must update TAIL as we walk back up the tree. 76 | (push (node-name node) tail) 77 | (setf node (node-parent node))) 78 | 79 | (when node 80 | (values 81 | ;; 1 82 | (node-data node) 83 | ;; 2 84 | (when tail 85 | (list-to-delimited-string tail "/")))))) 86 | 87 | ;; Exported 88 | ;; Finds the node matching PATH (a string, or a list of path component strings). 89 | ;; If the node is found and it has non-nil data, the data is returned. 90 | ;; Otherwise nil is returned. 91 | (defun find-data (node path) 92 | (multiple-value-bind (node tail) 93 | (search-directory-tree node path) 94 | (when (and node (null tail)) 95 | (node-data node)))) 96 | 97 | ;; Exported 98 | (defmethod canonicalize-path ((path list)) 99 | (let ((res "/")) 100 | (dolist (component path) 101 | (setf res (append-name res component))) 102 | res)) 103 | 104 | ;; Exported 105 | (defmethod canonicalize-path ((path string)) 106 | (canonicalize-path (parse-directory-path path))) 107 | 108 | 109 | ;;;;;;;;;;;;; 110 | ;; Innards ;; 111 | ;;;;;;;;;;;;; 112 | 113 | ;; Return the child of NODE which is named CHILD-NAME, or nil if 114 | ;; no such child. 115 | (defun get-node-child (node child-name) 116 | (cdr (assoc child-name (node-children node) :test #'string=))) 117 | 118 | ;; Repeatedly evaluates BODY with CHILD-NODE-VAR bound each 119 | ;; child of NODE. 120 | (defmacro do-children ((child-node-var node) &body body) 121 | (let ((entry (gensym "entry"))) 122 | `(dolist (,entry (node-children ,node)) 123 | (let ((,child-node-var (cdr ,entry))) 124 | ,@body)))) 125 | 126 | (defmethod print-object ((node node) stream) 127 | (let (child-names) 128 | (do-children (child-node node) 129 | (push (node-name child-node) child-names)) 130 | 131 | (format stream "[node ~s with data ~a, and children ~s]" 132 | (node-name node) 133 | (node-data node) 134 | child-names))) 135 | 136 | (defmethod search-directory-tree ((node node) (path list)) 137 | (if* path 138 | then (let ((child (get-node-child node (first path)))) 139 | (if* child 140 | then ;; Good to descend 141 | (search-directory-tree child (rest path)) 142 | else ;; No child by that name. Can't go any further. 143 | ;; Return the node that we stopped on and the remaining path components. 144 | (values node path))) 145 | else ;; Path exhausted. Return the node that we stopped on. 146 | node)) 147 | 148 | (defmethod search-directory-tree ((node node) (path string)) 149 | (search-directory-tree node (parse-directory-path path))) 150 | 151 | ;; Makes a new node and adds it as a child (named CHILD-NAME) of NODE. 152 | (defun add-child (node child-name) 153 | (let ((child-node (make-node :name child-name))) 154 | (setf (node-parent child-node) node) 155 | (push (cons child-name child-node) (node-children node)) 156 | child-node)) 157 | 158 | (defun append-name (node-path child-name) 159 | (if* (match-re "/$" node-path) 160 | then ;; current node name ends with a slash. 161 | (concatenate 'string node-path child-name) 162 | else ;; current node names does not end with a slash. 163 | ;; add one. 164 | (concatenate 'string node-path "/" child-name))) 165 | 166 | (defun map-directory-tree-1 (node node-path callback) 167 | ;; Call the callback for this node if it has data. 168 | (let ((data (node-data node))) 169 | (when data 170 | (funcall callback node-path data))) 171 | 172 | (do-children (child-node node) 173 | (map-directory-tree-1 child-node (append-name node-path (node-name child-node)) callback))) 174 | 175 | ;; Parses PATH (a string) and returns 176 | ;; a list of component names. 177 | ;; Note that this does not do special things with components 178 | ;; like "." and ".." (though it could). 179 | (defun parse-directory-path (path) 180 | (check-type path string) 181 | 182 | (let ((res (split-re "/+" path))) ;; split on sequences of one or more slashes 183 | ;; Discard any leading blank string component (which will occur 184 | ;; if PATH begins with a slash). 185 | (when (and (first res) (string= (first res) "")) 186 | (pop res)) 187 | 188 | res)) 189 | 190 | #+ignore 191 | (defun test-parse-directory-path () 192 | (let ((cases '( 193 | ("" nil) 194 | ("/" nil) 195 | ("/a" ("a")) 196 | ("a" ("a")) 197 | ("a/" ("a")) 198 | ("/a/b" ("a" "b")) 199 | ("a/b" ("a" "b")) 200 | ("/a/b/" ("a" "b")) 201 | ("a/b/" ("a" "b")) 202 | ))) 203 | (loop for (path expected-output) in cases 204 | do (let ((output (parse-directory-path path))) 205 | (when (not (equalp output expected-output)) 206 | (error "Expected ~s to parse to ~s, but got ~s instead" 207 | path expected-output output)))))) 208 | -------------------------------------------------------------------------------- /doc/C702.PDF: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/nfs/6df1f6970274e7dd02f0010a7a170369fc09834c/doc/C702.PDF -------------------------------------------------------------------------------- /doc/access-control.txt: -------------------------------------------------------------------------------- 1 | 2 | *hosts-allow* and *hosts-deny* control which hosts are allowed to 3 | access the NFS server. When an NFS or mount request comes in, the IP 4 | address of the host making the request is matched against the entries 5 | in *hosts-allow* first, then the entries in *hosts-deny*, until a 6 | match is found. The first match found is used. If no match is 7 | found, access is allowed. Therefore, if both *hosts-allow* and 8 | *hosts-deny* are empty lists, all clients will be allowed access. 9 | 10 | *hosts-allow* and *hosts-deny* should be list of IP addresses and 11 | optional masks. An IP address/mask is a string like so: 12 | 13 | "a.b.c.d" -- Exact match of IP address a.b.c.d. 14 | "a.b.c.d/w.x.y.z" -- IP address/netmask format. Matches a group of hosts. 15 | "a.b.c.d/m" -- CIDR network format. Matches a group of hosts. 16 | t -- (the symbol, not a string) matches all hosts. 17 | 18 | Examples: 19 | 20 | "192.168.5.0/255.255.255.0" will match all 192.168.5.XXX hosts. 21 | "192.168.5.0/24" will match all 192.168.5.XXX hosts as well. 22 | 23 | If you want a "deny all but some" setup, you can use configuration 24 | values like so: (in nfs.cfg) 25 | 26 | (*hosts-allow* ("192.168.5.32" "192.168.5.99" "10.1.3.0/24" 27 | "10.16.0.0/255.255.0.0")) 28 | (*hosts-deny* (t)) 29 | 30 | This will allow hosts 192.168.5.32, 192.168.5.99, all 10.1.3.x hosts, 31 | and all 10.16.x.x hosts to talk to the NFS service and any other host 32 | will be denied. 33 | 34 | If you want a "allow all but some" setup, you can do something like: 35 | 36 | (*hosts-allow* nil) 37 | (*hosts-deny* ("192.0.0.0/8" "10.0.0.0/255.0.0.0")) 38 | 39 | This will allow all hosts except for 192.x.x.x and 10.x.x.x hosts to 40 | talk to the NFS server. 41 | 42 | 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /doc/debugging.txt: -------------------------------------------------------------------------------- 1 | 2 | ## Debugging 3 | 4 | Interactive debugging of server: 5 | 6 | :ld load.cl 7 | 8 | Then, for debugging: 9 | 10 | (debugmain) ;; main.cl 11 | 12 | Or, without debugging: 13 | 14 | (setf *configfile* "nfs.cfg") 15 | (read-nfs-cfg *configfile*) 16 | (startem) 17 | 18 | ******************************************************************************* 19 | 20 | :cd d:/src/nfs50/ 21 | (load "load.cl") 22 | (setf *configfile* "nfs.cfg") 23 | (read-nfs-cfg *configfile*) 24 | (startem) 25 | 26 | (prof:start-profiler) 27 | 28 | (prof:stop-profiler) 29 | (defun doit (file) 30 | (with-open-file (*standard-output* file :direction :output 31 | :if-exists :supersede) 32 | (prof:show-flat-profile) 33 | (prof:show-call-graph) 34 | #+ignore (prof:disassemble-profile 'excl::g-read-vector-2))) 35 | (doit "y:/nfs.82brc5") 36 | (doit "y:/nfs.81") 37 | 38 | (prof:show-flat-profile) 39 | (prof:show-call-graph) 40 | 41 | OLD INFO: 42 | 43 | :cd c:/cygwin/home/layer/src/nfs 44 | :ld load 45 | (setf *configfile* "c:/AllegroNFS/nfs.cfg") 46 | (read-nfs-cfg *configfile*) 47 | (startem) 48 | 49 | -------------------------------------------------------------------------------- /doc/notes.txt: -------------------------------------------------------------------------------- 1 | *Implementation notes* 2 | 3 | *Discussion of NFSv2 readdir* 4 | 5 | The readdir call works as follows: The client sends to the server the 6 | directory which it wants to read, along with a special piece of data 7 | called a cookie. If the cookie is all zeros, the directory read 8 | operation starts working from the beginning of the directory. The 9 | server fills in a data buffer with directory entries. Each entry has 10 | a cookie associated with it. The cookie is basically a pointer to the 11 | _next_ entry. The server puts as much data into the buffer as it can. 12 | If the buffer fills up, the readdir operation returns w/ a "more data" 13 | indicator. If the client sees this indicator, it makes a note of the 14 | cookie for the last entry it received. Since the cookie points to the 15 | next entry, the client can use that cookie to make another readdir 16 | call that starts w/ that next entry. Repeating this until the "more 17 | data" indicator is no longer set, a client can read the entire 18 | directory contents. 19 | 20 | This is all great unless the directory incurs a change between readdir 21 | calls. If a directory changes between readdir calls, a cookie that a 22 | client is holding may become invalid. NFSv2 provides no way for a 23 | server to indicate to a client that its cookie is no longer any good. 24 | 25 | This situation can happen quite easily when the 'rm -r' command is 26 | used on the client to delete a directory tree on the server. rm -r is 27 | typically implemented like so: 28 | 29 | char buf[bufsize]; 30 | 31 | /* depth first */ 32 | while (getdents(directory_fd, buf, bufsize)) { 33 | foreach entry (buf) { 34 | if (directoryp entry) 35 | rm_recursive(entry) 36 | else 37 | unlink(entry); 38 | } 39 | } 40 | 41 | The getdents syscall call eventually boils down to a readdir call. 42 | Depending on how large 'bufsize' is, getdents calls (thus readdir 43 | calls) may be interspersed with unlink calls. This means that the 44 | directory is changing as it is being read in small pieces. This can 45 | lead to the rm -r command getting confused and not completing 46 | correctly. 47 | 48 | You've probably never experienced this problem w/ Unix NFS servers. I 49 | believe the reason for this is: 50 | 1) Those NFS servers are kernel-mode software. 51 | 2) The NFS readdir call was designed w/ Unix filesystems in mind. 52 | 53 | Typical Unix filesystems store directories as just a special form of a 54 | regular file. The file contains variable-length records. The records 55 | are entries in the directory. An example follows: 56 | 57 | directory: 58 | offset 0: filea 59 | offset 10: fileb 60 | offset 20: filec 61 | 62 | Some of these records may be empty. An empty record would result if, 63 | say, 'filea' were unlinked from the above example. Instead of 64 | shifting all the entries down, the 'filea' entry is just marked as 65 | unused. This saves time... and also gives rise to why rm -r works 66 | fine w/ Unix NFS servers. 67 | 68 | User-mode programs generally don't see this low-level structure of 69 | directories, but kernel-mode programs (thus Unix NFS servers) do. The 70 | directory offsets in the above example make perfect cookies for the 71 | readdir call. A readdir call using the above example might return: 72 | 73 | filea cookie: 10 74 | fileb cookie: 20 75 | filec cookie: xxxx (end of listing) 76 | 77 | (recall: the cookie for an entry identifies the entry that follows) 78 | 79 | Even if rm -r only read and unlinked one directory entry per loop, it 80 | would work fine becauses the actual directory contents don't shift 81 | when an unlink occurs, therefore the cookies wouldn't shift. 82 | 83 | 84 | The NFS project that you are dealing with now is not a Unix kernel- 85 | mode program. Quite the opposite, in fact. It's a lowly user-mode 86 | Windows program. It is likely that FAT and/or NTFS filesystems, like 87 | their Unix filesystem counterparts, don't shift directory contents 88 | when unlinking files... but unfortunately we can't get at the raw 89 | directory information easily (at least, not as far as I can tell). 90 | This makes cookie selection difficult. 91 | 92 | This program uses the Common Lisp (directory) function to read the 93 | contents of a directory to respond to a 'readdir' call. To combat the 94 | 'rm -r' issue, the following things were done. 95 | 96 | 1) Calls to (directory) are cached for *nfs-dircache-update-interval* 97 | (defaults to 2) seconds. The cache contains the contents of the 98 | directory, along with a timestamp. 99 | 2) NFS operations that modify a directory (unlink, create, rename) 100 | will be recorded in the directory cache (as long as they occur 101 | within *nfs-dircache-update-interval* of the last operation). 102 | 3) The unlink operation doesn't shift the contents of the directory 103 | listing. Instead, it just sets the corresponding entry to nil. 104 | The code that handles the readdir call knows to ignore these 105 | entries. 106 | 4) The cookies that the readdir handler uses are indexes into the 107 | cached directory listing. 108 | 109 | This caching of (directory) calls also has the side effect of making 110 | the operations a bit faster. 111 | 112 | For an rm -r to work w/o problems, *nfs-dircache-update-interval* must 113 | be large enough to keep the directory contents cached while rm -r 114 | descends through subdirectories. You can adjust this parameter if you 115 | are having problems. 116 | 117 | Note that while a directory listing is cached, any changes to the 118 | directory made by a local user on the NFS server will not be visible 119 | to the NFS client for *nfs-dircache-update-interval* seconds. You'll 120 | want to adjust *nfs-dircache-update-interval* to balance between rm -r 121 | success and confusion avoidance. 122 | 123 | *Other information caching* 124 | 125 | The NFS protocol doesn't have an 'open' call. Clients simply make 126 | read and write calls to files. A basic implementation of a user-mode 127 | NFS server would have to open the file, do the read or write 128 | operation, then close the file.... for every block of data. 129 | 130 | To avoid this potential constant opening and closing of the file, this 131 | NFS server employs and open file cache. A parameter 132 | *open-file-reap-time* (defaults value: 2) controls how long files are 133 | held open after their last access. The default value should be fine 134 | for most people but you may want to make an adjustment if your 135 | situation calls for it. Just remember that a file will stay open 136 | *open-file-reap-time* seconds longer than the last access to it.. so 137 | attempted accesses on the Windows-side may not work during that time 138 | [due to file locking]. 139 | 140 | When *open-file-reap-time* is zero, don't cache open files in the 141 | *open-file-cache* hash table. This will incur a performance penalty, 142 | but one that some customers may be willing to bear for the benefit of 143 | not running into sharing violations on Windows, when accessing files 144 | modified or created by clients. 145 | 146 | Similarly, calls to stat() are cached for *attr-cache-reap-time* 147 | (default value: 5) seconds. Most NFS calls return information from 148 | the stat() call along with their results. Keep this in mind if you 149 | edit a file or directory locally on the NFS server. NFS clients may 150 | not see the change for up to *attr-cache-reap-time* seconds. 151 | 152 | Note that *attr-cache-reap-time* should be larger than 153 | *open-file-reap-time*. This is because the open file reaper needs the 154 | cached stat information when closing a file that was opened for 155 | writing, so that it can update the atime/mtime of the file. 156 | -------------------------------------------------------------------------------- /doc/profiling.txt: -------------------------------------------------------------------------------- 1 | (fi:common-lisp 2 | "*common-lisp*" "c:/cygwin/home/layer/nfs/" 3 | "c:/acl82.patched/mlisp" 4 | (quote ("+B" "+cn")) "localhost" nil) 5 | 6 | (fi:common-lisp 7 | "*common-lisp*" "c:/cygwin/home/layer/nfs.acl90/" 8 | "c:/acl90/mlisp" 9 | (quote ("+B" "+cn")) "localhost" nil) 10 | 11 | when switching branches: 12 | 13 | git checkout .. 14 | make clean rpc 15 | 16 | (setq *load-source-file-info* nil) 17 | (setq *load-source-debug-info* nil) 18 | (setq *load-local-names-info* nil) 19 | (setq *load-xref-info* nil) 20 | 21 | :cd c:/cygwin/home/layer/nfs 22 | :ld load 23 | (setf *configfile* "c:/AllegroNFS/nfs.cfg") 24 | (read-nfs-cfg *configfile*) 25 | (startem) 26 | 27 | :cd c:/cygwin/home/layer/nfs.acl90 28 | :ld load 29 | (setf *configfile* "c:/AllegroNFS/nfs.cfg") 30 | (read-nfs-cfg *configfile*) 31 | (startem) 32 | 33 | (room) 34 | (setf *configfile* "c:/AllegroNFS/nfs.cfg") 35 | (read-nfs-cfg *configfile*) 36 | (startem) 37 | (room) 38 | 39 | (prof:start-profiler) 40 | (prof:start-profiler :type :space) 41 | 42 | ;; ./hammernfs hobart256:/e/ACL82.iso 43 | (room) 44 | 45 | 46 | 47 | (prof:stop-profiler) 48 | (prof:show-flat-profile) 49 | (prof:show-call-graph) 50 | (room t) 51 | 52 | (disassemble 'excl::memcpy) 53 | (disassemble 'excl::memcpy-up) 54 | 55 | (trace excl::start-emacs-process-for-network-stream) 56 | (excl:new-start-emacs-lisp-interface :port 12000 :background-streams t) 57 | (setq p (mp:process-run-function "Run Bar Process(2)" 58 | (lambda () (excl::run-status-process excl::*null-stream*)))) 59 | (setf (mp::process-interruptible-p p) nil) 60 | 61 | (setq socket (socket:make-socket :remote-host "localhost" :remote-port 12000)) 62 | 63 | (setq before (get-internal-run-time)) 64 | 65 | 66 | (setq after (get-internal-run-time)) 67 | (format t "run-time diff=~s~%" (- after before)) 68 | ;; fast: 13213 -- ~40% in task manager 69 | ;; slow: 18704 -- 15-30% in task manager 70 | 71 | 72 | -------------------------------------------------------------------------------- /doc/release-notes.txt: -------------------------------------------------------------------------------- 1 | Now in ../README.md in the "Release Notes" section 2 | -------------------------------------------------------------------------------- /doc/testing.txt: -------------------------------------------------------------------------------- 1 | Correctness and performance testing are detailed here. 2 | 3 | ******************************************************************************* 4 | ** Correctness 5 | ******************************************************************************* 6 | 7 | freon$ make runtests 8 | 9 | setup: 10 | 11 | * See the variables near the `runtests' rule in Makefile, make sure 12 | they are all correct 13 | * windows: thunder: 14 | - sshd must be running 15 | - make a directory c:/tmp/nfs.test and put a copy of some large 16 | file there and call it `nfstestfile' 17 | - NFS shares c:/ as '/c' and c:/tmp/nfs.test as `/nfs.test' 18 | specify the uid of the test user 19 | * linux: gremlin: 20 | - make sure /home/tmp/layer/nfs.test exists and put a copy of the 21 | same `nfstestfile' there (via some means other than NFS) 22 | - `make testnfs` 23 | - mounts /net//c and .../nfs.test exist 24 | ie: sudo mkdir /net//c 25 | sudo mount :/c /net//c ... 26 | - `export ONALL_SSH_PORT_thunder=8100` where 8100 is taken from 27 | your SSH config file and is your assigned SSHD port number 28 | * Manually test to verify that large uid is accepted [bug26156]: 29 | Create a user with a uid bigger than a 32-bit fixnum 30 | such as 600000000 and modify config file to specify 31 | this user. 32 | 33 | ******************************************************************************* 34 | ** Performance 35 | ******************************************************************************* 36 | 37 | The following setup produces more stable results than anything found 38 | so far: 39 | - VMware Fusion on a Mac Pro 40 | - aNFS server: Windows 7 x64 Enterprise 41 | - test client: Ubuntu 16.04 42 | The test client cannot be run on Windows, because the test program 43 | fails (it seems to be a bug in Cygwin). 44 | 45 | The following script, test/performance.sh, runs `hammernfs' in many 46 | different combinations of block size (from 512 to 8192), NFS protocol 47 | versions (2 & 3) and transport layers (tcp & udp). 48 | 49 | Setup: 50 | 51 | Server: 52 | 53 | * put a 30M file into the NFS share "nfs.test", which must have write 54 | access to the root of the nfs.test share. There is usually one in 55 | freon:/home/tmp/layer/nfs.test/. 56 | 57 | * start the task manager and minimize it, and wait for the system to 58 | settle into a true idle. Sometimes after starting the VM, Windows 59 | will go crazy for a while doing who knows what. 60 | 61 | Client: 62 | 63 | * OPTIONAL: on Ubuntu, if NFS client utilities are wanted, for 64 | testing (for "mount -t nfs" to work): 65 | 66 | # apt-get install nfs-common 67 | 68 | * "make hammernfs" and then "scp -rq" this nfs repo directory over to 69 | the client. 70 | 71 | * find the IP of the server, and do 72 | 73 | $ test/performance.sh 192.132.95.228:/nfs.test/nfstestfile 6.3.2.rc1 74 | 75 | * copy the results file back here, git add it, and do "make results" 76 | to see how it stacks up against previous versions. 77 | 78 | If multiple versions are tested, then do this when one version is 79 | finished testing: 80 | 81 | - uninstall old version 82 | - reboot 83 | - install new version 84 | - start task manager, performance tab and wait until the machine 85 | settles, then minimize the task manager 86 | 87 | Now, run the tests on the client. NOTE: the client machine is not 88 | rebooted between runs. 89 | -------------------------------------------------------------------------------- /doc/todo.txt: -------------------------------------------------------------------------------- 1 | 2 | ******************************************************************************* 3 | For the next major version, rethink the way file handles are 4 | implemented: 5 | 6 | Currently file handles and filename information are stored in the same 7 | structure. Hard links throw a wrench into this mechanism. 8 | 9 | How about separate structures for directory and handle information? 10 | This would be more like unix. 11 | 12 | What is the directory information used for anyway? For mapping 13 | filenames to file handles. Would it be reasonable to make this 14 | separate? Pros/cons? The current scheme is simple (without hard links). 15 | 16 | Important needs: 17 | mapping of file handle to a pathname. 18 | A file handle with multiple links may have multiple pathnames. How do 19 | we manage this? At first it might seem that the name of the 20 | "first" link could just be used. However, if that file is deleted, 21 | then subsequence operations will fail. A possible workaround is to 22 | keep a list of known pathnames and if a filename is unlinked from a 23 | directory, update the list. That's as good as any other methods being 24 | used. 25 | 26 | ******************************************************************************* 27 | misc: 28 | - sparse file support 29 | - execute permissions issue (spr37568) 30 | 31 | ******************************************************************************* 32 | --- older stuff ---- 33 | 34 | nsm: How long do we try sending state-change notifications? 35 | nsm: How long do we try notify sending callbacks? 36 | nlm: How long do we try sending NLM_GRANTED messages? Forever? 37 | 38 | -------------------------------------------------------------------------------- /interval.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (defpackage :interval 5 | (:use :lisp :excl) 6 | (:export 7 | #:begins-before-p 8 | #:begins-after-p 9 | #:ends-after-p 10 | #:begins-within-p 11 | #:ends-within-p 12 | #:overlaps-p 13 | #:interval-subtract 14 | #:interval-subtract-pairs)) 15 | 16 | (in-package :interval) 17 | 18 | (defmacro begins-before-p (start1 end1 start2 end2) 19 | (declare (ignore end1 end2)) 20 | `(< ,start2 ,start1)) 21 | 22 | (defmacro begins-after-p (start1 end1 start2 end2) 23 | (declare (ignore start1 end2)) 24 | `(>= ,start2 ,end1)) 25 | 26 | ;; interval2 ends after interval 1 ends 27 | (defmacro ends-after-p (start1 end1 start2 end2) 28 | (declare (ignore start1 start2)) 29 | `(> ,end2 ,end1)) 30 | 31 | (defmacro begins-within-p (start1 end1 start2 end2) 32 | (declare (ignore end2)) 33 | `(and (>= ,start2 ,start1) (< ,start2 ,end1))) 34 | 35 | (defmacro ends-within-p (start1 end1 start2 end2) 36 | (declare (ignore start2)) 37 | `(and (> ,end2 ,start1) (<= ,end2 ,end1))) 38 | 39 | (defmacro overlaps-p (start1 end1 start2 end2) 40 | `(or (begins-within-p ,start1 ,end1 ,start2 ,end2) 41 | (ends-within-p ,start1 ,end1 ,start2 ,end2) 42 | (and (begins-before-p ,start1 ,end1 ,start2 ,end2) 43 | (ends-after-p ,start1 ,end1 ,start2 ,end2)))) 44 | 45 | (defun interval-subtract-1 (start1 end1 start2 end2) 46 | (cond 47 | ((not (overlaps-p start1 end1 start2 end2)) 48 | (values start1 end1)) 49 | 50 | ((begins-before-p start1 end1 start2 end2) 51 | (if* (ends-within-p start1 end1 start2 end2) 52 | then (values end2 end1) 53 | else nil)) 54 | 55 | (t ;; begins within 56 | (if* (ends-within-p start1 end1 start2 end2) 57 | then (values start1 start2 end2 end1) 58 | else (values start1 start2))))) 59 | 60 | (defun interval-subtract (start1 end1 start2 end2) 61 | (declare (optimize (speed 3))) 62 | (multiple-value-bind (a b c d) 63 | (interval-subtract-1 start1 end1 start2 end2) 64 | (if (null a) 65 | (return-from interval-subtract)) 66 | (if* (and c (= c d)) 67 | then (setf c nil) 68 | (setf d nil)) 69 | (if* (= a b) 70 | then (setf a c) 71 | (setf b d) 72 | (setf c nil) 73 | (setf d nil)) 74 | (values a b c d))) 75 | 76 | ;; Return a list of the remaining intervals (in cons form) 77 | (defun interval-subtract-pairs (start end pairs) 78 | (dolist (pair pairs) 79 | (multiple-value-bind (nstart1 nend1 nstart2 nend2) 80 | (interval-subtract start end (car pair) (cdr pair)) 81 | (if* nstart2 82 | then (return-from interval-subtract-pairs 83 | (nconc (interval-subtract-pairs nstart1 nend1 pairs) 84 | (interval-subtract-pairs nstart2 nend2 pairs))) 85 | elseif nstart1 86 | then (setf start nstart1) 87 | (setf end nend1) 88 | else (return-from interval-subtract-pairs nil)))) 89 | (list (cons start end))) 90 | 91 | 92 | -------------------------------------------------------------------------------- /ipaddr.cl: -------------------------------------------------------------------------------- 1 | ;; This software is Copyright (c) Franz Inc., 2001-2014. 2 | ;; Franz Inc. grants you the rights to distribute 3 | ;; and use this software as governed by the terms 4 | ;; of the Lisp Lesser GNU Public License 5 | ;; (http://opensource.franz.com/preamble.html), 6 | ;; known as the LLGPL. 7 | 8 | (in-package :user) 9 | 10 | (eval-when (compile) 11 | (declaim (optimize (speed 3)))) 12 | 13 | (eval-when (compile load eval) 14 | (require :acldns) 15 | (require :regexp2) 16 | (require :sock)) 17 | 18 | (defstruct network-address 19 | network 20 | mask) 21 | 22 | (eval-when (compile eval load) 23 | (defvar *ipaddr-re* "[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+")) 24 | 25 | (defun valid-ipaddr-p (thing &key full) 26 | (if* full 27 | then (match-re 28 | #.(concatenate 'simple-string 29 | "^" *ipaddr-re* "/" 30 | "(" *ipaddr-re* "|\\d+)" 31 | "$") 32 | thing) 33 | else (match-re 34 | #.(concatenate 'simple-string 35 | "^" *ipaddr-re* "$") 36 | thing))) 37 | 38 | (defun my-dotted-to-ipaddr (addr) 39 | (if* (not (valid-ipaddr-p addr)) 40 | then (error "Invalid address specification") 41 | else (socket:dotted-to-ipaddr addr))) 42 | 43 | ;; Acceptable formats: 44 | ;; a.b.c.d 45 | ;; a.b.c.d/x 46 | ;; a.b.c.d/x.y.z.w 47 | ;; t (shortcut for 0.0.0.0/0) 48 | 49 | (defun parse-addr (addr &aux (mask #xffffffff)) 50 | ;; convenience 51 | (if (eq addr t) 52 | (setf addr "0.0.0.0/0")) 53 | (setf addr (string-trim '(#\space) addr)) 54 | (if (string= addr "") 55 | (error "blank string passed to parse-addr")) 56 | (if* (valid-ipaddr-p addr :full t) 57 | then (let* ((slashpos (position #\/ addr)) 58 | (network (my-dotted-to-ipaddr 59 | (subseq addr 0 (or slashpos (length addr)))))) 60 | (if* slashpos 61 | then (setf addr (subseq addr (1+ slashpos))) 62 | (setf mask 63 | (if (position #\. addr) 64 | (my-dotted-to-ipaddr addr) 65 | (masklength-to-mask addr))) 66 | (setf network (logand network mask))) 67 | (make-network-address 68 | :network network 69 | :mask mask)) 70 | else ;; Assume it's a host name and try to resolve it 71 | (let ((ip (ignore-errors (socket:lookup-hostname addr)))) 72 | (when (null ip) 73 | (error "Could not resolve host name ~s." addr)) 74 | (make-network-address 75 | :network ip 76 | :mask mask)))) 77 | 78 | (defun masklength-to-mask (value) 79 | (if (stringp value) 80 | (setf value (parse-integer value))) 81 | (if (or (< value 0) (> value 32)) 82 | (error "Invalid mask length: ~A" value)) 83 | (- #xffffffff (1- (expt 2 (- 32 value))))) 84 | 85 | #+ignore 86 | (defun test (net) 87 | (declare (optimize speed (safety 0) (debug 0))) 88 | (let ((addr (socket:dotted-to-ipaddr "1.2.3.4"))) 89 | (dotimes (n 10000000) 90 | (addr-in-network-p addr net)))) 91 | 92 | #+ignore 93 | (defun addr-in-network-p (addr net) 94 | (declare (optimize speed (safety 0) (debug 0))) 95 | (if (stringp addr) 96 | (setf addr (socket:dotted-to-ipaddr addr))) 97 | (= (logand addr (network-address-mask net)) 98 | (network-address-network net))) 99 | 100 | ;; Optimized version 101 | (defun addr-in-network-p (addr net) 102 | (declare (optimize speed (safety 0) (debug 0))) 103 | (if (stringp addr) 104 | (setf addr (socket:dotted-to-ipaddr addr))) 105 | (let ((addr (comp::ll :integer-to-mi addr)) 106 | (mask (comp::ll :integer-to-mi (network-address-mask net))) 107 | (network (comp::ll :integer-to-mi (network-address-network net)))) 108 | (eq (comp::ll :logand addr mask) network))) 109 | 110 | (defun network-address-to-printable-string (network-address) 111 | (let ((mask (network-address-mask network-address)) 112 | (addr (socket:ipaddr-to-dotted 113 | (network-address-network network-address)))) 114 | (cond ((and (integerp mask)(= mask 0) 115 | (stringp addr) (string= addr "0.0.0.0")) 116 | (setf mask nil 117 | addr "*")) 118 | ((= #xffffffff mask) 119 | (setf mask nil) 120 | (let ((name (socket:ipaddr-to-hostname 121 | (network-address-network network-address)))) 122 | (when name 123 | (setf addr name)))) 124 | (t (setf mask (socket:ipaddr-to-dotted mask)))) 125 | (format nil "~A~@[/~A~]" addr mask))) 126 | -------------------------------------------------------------------------------- /license.readme: -------------------------------------------------------------------------------- 1 | 2 | Before you publish a new version, do: 3 | 4 | 1. Fill columns to 60 after doing: 5 | (setq fill-column 60) 6 | 7 | 2. Replace tabs with spaces: 8 | (untabify (point-min) (point-max)) 9 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | nfs -- CL-based NFS server for Windows 2 | 3 | Allegro NFS is licensed under the terms of the Lisp Lesser GNU 4 | Public License (http://opensource.franz.com/preamble.html), known as 5 | the LLGPL. The LLGPL consists of a preamble (see above URL) and the 6 | LGPL. Where these conflict, the preamble takes precedence. 7 | nfs is referenced in the preamble as the "LIBRARY." 8 | -------------------------------------------------------------------------------- /load.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (in-package :user) 5 | 6 | ;;;;;; NONE OF THESE SHOULD BE ON IN AN PRODUCTION BUILD 7 | ;;(pushnew :nfs-debug *features* :test #'eq) 8 | ;;(pushnew :nfs-profiling *features* :test #'eq) 9 | ;;(pushnew :nfs-telnet-server *features* :test #'eq) 10 | 11 | (format t "~&~% *features*=~S~%" *features*) 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;; RPC build 15 | 16 | (load (compile-file-if-needed "rpcgen")) 17 | 18 | (dolist (file (list "sunrpc.x" "portmap.x" "mount.x" "nlm.x" "nsm.x")) 19 | (write-line file) 20 | (rpcgen file)) 21 | 22 | (rpcgen "nfs.x" :out-base "gen-nfs") 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | (eval-when (compile load eval) 27 | (defparameter *filelist* 28 | '("config-defs" 29 | #-nfs-lisp-bsw "bswap" 30 | "utf8" 31 | "utils" 32 | "xdr" 33 | "unicode-file" 34 | "sunrpc-common" 35 | "gen-nfs-common" 36 | "portmap-common" 37 | "mount-common" 38 | "nsm-common" 39 | "nfs-common" 40 | "nfs-shared" 41 | "nlm-common" 42 | "sunrpc" 43 | "portmap-client" 44 | "sunrpc-service" 45 | "portmap" 46 | "ipaddr" 47 | "directory-tree" 48 | "export" 49 | "configure" 50 | "nfs-log" 51 | "fhandle" 52 | "mountd" 53 | "nsm-client" 54 | "nsm" 55 | "attr" 56 | "dir" 57 | "openfile" 58 | "interval" 59 | "nlm-client" 60 | "locking" 61 | "nlm" 62 | "gen-nfs-client" 63 | "main" ;; needs to be before "nfs" 64 | "nfs" 65 | #+nfs-telnet-server "telnet" 66 | #+nfs-demo "demoware/demoware2" 67 | )) 68 | ) 69 | 70 | (eval-when (compile load eval) 71 | (setq excl::*warn-smp-usage* nil) 72 | 73 | (require :osi) 74 | (use-package :excl.osi) 75 | (with-compilation-unit () 76 | (dolist (file *filelist*) 77 | (load (compile-file-if-needed file))))) 78 | 79 | (defun buildit () 80 | ;; This will be fixed before 7.0 is released. Remove then. 81 | #+(version>= 7)(progn 82 | (require :winapi) 83 | (require :res)) 84 | (let (filelist) 85 | (dolist (file (reverse *filelist*)) 86 | (push (concatenate 'string file ".fasl") filelist)) 87 | 88 | (generate-executable 89 | "nfs" 90 | (append '(:sock :acldns :seq2 :foreign :efmacs :autozoom :disasm 91 | #+nfs-profiling :prof 92 | #+nfs-profiling :pe ;; needed for prof:show-flat-profile 93 | #+nfs-debug :trace) 94 | filelist) 95 | :runtime #+nfs-profiling :partners #-nfs-profiling :standard 96 | :runtime-bundle t 97 | :icon-file "nfs.ico") 98 | 99 | ;; Set the command line flags. 100 | (run-shell-command 101 | ;; +cx hide console 102 | ;; +Ti remove "interrupt lisp" from system tray menu 103 | ;; +Cx disable console window exit. 104 | ;; +N sets program name used in system tray menu 105 | (format nil 106 | "~a -o nfs/nfs.exe +t ~s +cx +Ti +Cx +N \"Allegro NFS ~a\"" 107 | (truename "sys:bin;setcmd.exe") 108 | #+nfs-demo (format nil "Allegro NFS ~a Server demo" *nfsd-version*) 109 | #-nfs-demo (format nil "Allegro NFS ~a Server" *nfsd-version*) 110 | *nfsd-version*) 111 | :show-window :hide))) 112 | 113 | 114 | -------------------------------------------------------------------------------- /locking.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | ;; Better locking interface than the MSVCRT _locking 5 | 6 | (ff:def-foreign-call _get_osfhandle ((fd :int))) 7 | 8 | (ff:def-foreign-call LockFile ((handle :int) 9 | (offsetlow :unsigned-int) 10 | (offsethigh :unsigned-int) 11 | (countlow :unsigned-int) 12 | (counthigh :unsigned-int)) 13 | :error-value :os-specific) 14 | 15 | (ff:def-foreign-call UnlockFile ((handle :int) 16 | (offsetlow :unsigned-int) 17 | (offsethigh :unsigned-int) 18 | (countlow :unsigned-int) 19 | (counthigh :unsigned-int)) 20 | :error-value :os-specific) 21 | 22 | (defconstant ERROR_LOCK_VIOLATION 33) 23 | (defconstant ERROR_NOT_LOCKED 158) 24 | 25 | ;; Returns 't' if successful, nil if already locked, and 26 | ;; signals an error otherwise. 27 | (defun my-lock-file (stream offset length) 28 | (multiple-value-bind (status err) 29 | (LockFile (_get_osfhandle (excl.osi::stream-to-fd stream)) 30 | (logand offset #xffffffff) 31 | (logand (ash offset -32) #xffffffff) 32 | (logand length #xffffffff) 33 | (logand (ash length -32) #xffffffff)) 34 | (if* (zerop status) 35 | then ;; Something didn't work out 36 | (if* (= err ERROR_LOCK_VIOLATION) 37 | then nil 38 | else (error "Lockfile failed with code ~d" err)) 39 | else t))) 40 | 41 | ;; Returns 't' if successful, 'nil' if Windows claims that the 42 | ;; region wasn't lock before. 43 | ;; signals an error otherwise 44 | (defun my-unlock-file (stream offset length) 45 | (multiple-value-bind (status err) 46 | (UnlockFile (_get_osfhandle (excl.osi::stream-to-fd stream)) 47 | (logand offset #xffffffff) 48 | (logand (ash offset -32) #xffffffff) 49 | (logand length #xffffffff) 50 | (logand (ash length -32) #xffffffff)) 51 | (if* (zerop status) 52 | then ;; Something didn't work out 53 | (if* (= err ERROR_NOT_LOCKED) 54 | then nil 55 | else (error "Unlockfile failed with code ~d" err)) 56 | else t))) 57 | -------------------------------------------------------------------------------- /main.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (eval-when (compile eval load) (require :ntservice)) 5 | 6 | (in-package :user) 7 | 8 | (defparameter *pmap-process* nil) 9 | (defparameter *mountd-process* nil) 10 | (defparameter *nfsd-process* nil) 11 | (defparameter *nsm-process* nil) 12 | (defparameter *nlm-process* nil) 13 | 14 | #+nfs-telnet-server ;; because the first thing you want to do is `trace' 15 | (eval-when (eval load) (require :trace)) 16 | 17 | (defun ping-nfsd () 18 | (multiple-value-bind (res error) 19 | (ignore-errors 20 | (sunrpc:with-rpc-client (cli "127.0.0.1" gen-nfs:*nfs-program* 2 :udp) 21 | (gen-nfs:call-nfsproc-null-2 cli nil))) 22 | (declare (ignore res)) 23 | (if (not error) 24 | t))) 25 | 26 | (defun check-nfs-already-running () 27 | (if (ping-nfsd) 28 | (bailout "~ 29 | An NFS server is already running on this machine. Aborting.~%"))) 30 | 31 | ;; Called by startem 32 | (defun start-subprocess (name function) 33 | "Runs FUNCTION in a new thread (named NAME). 34 | 35 | The call to FUNCTION in the new thread is wrapped with 36 | an error handler which will log and backtrace uncaught errors 37 | before terminating the thread. 38 | 39 | FUNCTION will be called with a single argument: a gate to 40 | be opened by FUNCTION when it has completed its initialization. 41 | 42 | Returns the subprocess object" 43 | 44 | (flet ((subprocess-wrapper (start-gate) 45 | (handler-bind 46 | ((error #'(lambda (c) 47 | (logit-stamp "~%Unhandled condition in thread ~a: ~a~%" 48 | (mp:process-name mp:*current-process*) 49 | c) 50 | (logit-stamp "Backtrace:~%~a~%" 51 | (with-output-to-string (s) 52 | (top-level.debug:zoom s :count t :length 10)))))) 53 | (funcall function start-gate)))) 54 | 55 | (let* ((start-gate (mp:make-gate nil)) 56 | (proc (mp:process-run-function name #'subprocess-wrapper start-gate))) 57 | (mp:process-wait (format nil "Waiting for ~a to start" name) 58 | #'mp:gate-open-p start-gate) 59 | 60 | proc))) 61 | 62 | (defun announce (state) 63 | (logit-stamp #+nfs-demo "Allegro NFS Server TRIAL version ~a ~a.~%" 64 | #-nfs-demo "Allegro NFS Server version ~a ~a.~%" 65 | *nfsd-long-version* 66 | state)) 67 | 68 | ;; Called by main and debugmain 69 | (defun startem (&rest args) 70 | (declare (ignore args)) 71 | ;;#+nfs-debug (trace stat) 72 | (setup-logging) 73 | (announce "initializing") 74 | (logit-stamp "commit id: ~a~%" *nfsd-commit-id*) 75 | (logit-stamp "Built with Allegro CL ~a~%" (lisp-implementation-version)) 76 | (check-nfs-already-running) 77 | 78 | (setf *pmap-process* 79 | (start-subprocess "portmapper" #'portmap:portmapper)) 80 | 81 | (setf *mountd-process* 82 | (start-subprocess "mountd" #'mount:MNT)) 83 | 84 | (setf *nsm-process* 85 | (start-subprocess "nsm" #'nsm:NSM)) 86 | 87 | (setf *nlm-process* 88 | (start-subprocess "nlm" #'nlm:NLM)) 89 | 90 | (setf *nfsd-process* 91 | (start-subprocess "nfsd" #'nfsd))) 92 | 93 | (defvar *shutting-down* (mp:make-gate nil)) 94 | 95 | (defun stopem () 96 | (logit-stamp "Stopping NFS server...") 97 | (when *nlm-process* (ignore-errors (mp:process-kill *nlm-process*))) 98 | (when *nsm-process* (ignore-errors (mp:process-kill *nsm-process*))) 99 | (when *nfsd-process* (ignore-errors (mp:process-kill *nfsd-process*))) 100 | (when *mountd-process* (ignore-errors (mp:process-kill *mountd-process*))) 101 | (when *pmap-process* (ignore-errors (mp:process-kill *pmap-process*))) 102 | 103 | (flet ((kill-by-name (name) 104 | (let ((proc (find name sys:*all-processes* :key #'mp:process-name :test #'string=))) 105 | (when proc 106 | (ignore-errors (mp:process-kill proc)))))) 107 | (kill-by-name "open file reaper") 108 | (kill-by-name "attr cache reaper") 109 | (kill-by-name "nsm callback retry loop") 110 | (kill-by-name "nlm retry loop") 111 | (kill-by-name "nlm notify loop") 112 | ) 113 | 114 | (mp:open-gate *shutting-down*) 115 | ;; Allow `mainloop' process to see the open gate. 116 | (sleep 1) 117 | 118 | (logit-stamp "Stopped NFS server")) 119 | 120 | (defun mainloop () 121 | (console-control :close :hide) 122 | (mp:process-wait "waiting for shutdown" 123 | #'mp:gate-open-p *shutting-down*) 124 | (logit-stamp "done.")) 125 | 126 | (defun debugmain (&optional (config "nfs.cfg")) 127 | (setf *configfile* config) 128 | (setf *exit-on-bailout* nil) 129 | (read-nfs-cfg *configfile*) 130 | (setf mount:*mountd-debug* t) 131 | (setf *nfs-debug* t) 132 | (setf portmap:*portmap-debug* t) 133 | ;;(setf *rpc-debug* t) 134 | (setf nsm:*nsm-debug* t) 135 | (setf nlm:*nlm-debug* t) 136 | (startem)) 137 | 138 | (defvar *service-name* "nfs") 139 | 140 | (defun main (&rest args) 141 | ;; Silence global gc warning. 142 | (setf *global-gc-behavior* :auto) 143 | 144 | (flet ((tnserver () 145 | #+nfs-telnet-server 146 | (progn 147 | (logit-stamp "Starting telnet server on port 1234~%") 148 | (start-telnet-server :port 1234)))) 149 | (let ((exepath (if (first args) (first args) "nfs.exe")) 150 | quiet) 151 | (setf *configfile* (merge-pathnames "nfs.cfg" exepath)) 152 | (pop args) ;; program name 153 | 154 | #+nfs-demo (demoware-setup) 155 | 156 | (if (member "/quiet" args :test #'string=) 157 | (setf quiet t)) 158 | (setf args (remove "/quiet" args :test #'string=)) 159 | 160 | (dolist (arg args) 161 | (cond 162 | ((string= arg "/install") 163 | (create-service exepath)) 164 | ((string= arg "/remove") 165 | (delete-service)) 166 | ((string= arg "/start") 167 | (start-service)) 168 | ((string= arg "/stop") 169 | (stop-service)) 170 | ((string= arg "/service") 171 | (setf *program-mode* :service) 172 | (read-nfs-cfg *configfile*) 173 | (tnserver) 174 | (ntservice:execute-service *service-name* 175 | #'mainloop 176 | :init #'startem 177 | :stop #'stopem) 178 | ;; just in case 179 | (exit 0)) 180 | ((string= arg "/console") 181 | (console quiet)) 182 | (t 183 | (logit "Ignoring unrecognized command line argument: ~A~%" arg)))) 184 | 185 | ;; If there were any switches, exit now. 186 | (when args 187 | (exit (if quiet 0 1))) 188 | 189 | ;; standalone execution. 190 | (read-nfs-cfg *configfile*) 191 | (startem) 192 | (tnserver) 193 | (mainloop)))) 194 | 195 | (defun create-service (path) 196 | (multiple-value-bind (success code) 197 | (ntservice:create-service 198 | *service-name* 199 | "Allegro NFS Server" 200 | (format nil "~A /service" path) 201 | :description "Allows NFS clients to access exported directories on this computer" 202 | :start :auto 203 | :interact-with-desktop nil) 204 | (if* success 205 | then (format t "NFS service successfully installed.~%") 206 | else (format t "NFS service installation failed: ~A" 207 | (ntservice:winstrerror code))))) 208 | 209 | (defun delete-service () 210 | (multiple-value-bind (success err place) 211 | (ntservice:delete-service *service-name*) 212 | (if* success 213 | then (format t "NFS service successfully uninstalled.~%") 214 | else (format t "NFS service deinstallation failed.~%(~A) ~A" 215 | place (ntservice:winstrerror err))))) 216 | 217 | 218 | 219 | (defun start-service () 220 | (multiple-value-bind (success err place) 221 | (ntservice:start-service *service-name*) 222 | (if* success 223 | then (format t "NFS service started.~%") 224 | else (start-stop-service-err "start" err place)))) 225 | 226 | (defun stop-service () 227 | (multiple-value-bind (success err place) 228 | (ntservice:stop-service *service-name*) 229 | (if* success 230 | then (format t "NFS service stopped.~%") 231 | else (start-stop-service-err "stop" err place)))) 232 | 233 | (defun start-stop-service-err (op err place) 234 | (format t "Failed to ~a NFS service: ~@[(~a): ~]~a~%" 235 | op place (if* (numberp err) 236 | then (ntservice:winstrerror err) 237 | else err)) 238 | (finish-output)) 239 | 240 | 241 | ;;; XXXX FIXME Temporary until building on 8.1 242 | ;;; use console-control :title then. 243 | (eval-when (compile load eval) 244 | (require :winapi)) 245 | 246 | (defun get-console-hwnd () 247 | (let ((where (ff:allocate-fobject '(:array :nat 4) :foreign-static-gc))) 248 | (win:GetWinMainArgs where) 249 | (ff:fslot-value where 3))) 250 | 251 | (defun set-window-title (title) 252 | (with-native-string (title title) 253 | (win:SetWindowText (get-console-hwnd) title))) 254 | -------------------------------------------------------------------------------- /misc/nfscleanreg.vbs: -------------------------------------------------------------------------------- 1 | ' VBScript 2 | ' $Id: nfscleanreg.vbs,v 1.3 2005/11/28 21:56:25 layer Exp $ 3 | 4 | ' adapted from code found here: 5 | ' http://mikesalsbury.com/mambo/content/view/134/ 6 | ' 7 | ' This function returns a "true/false" response if a 8 | ' given Windows Registry key exists. 9 | ' 10 | ' Since a script will generate an error if it attempts 11 | ' to read a non-existent Windows Registry key, we use 12 | ' a local "on error resume next" to keep executing 13 | ' normally if the error occurs. 14 | ' 15 | Function regEntryExists(theEntry) 16 | On error resume next 17 | Set shell = WScript.CreateObject("WScript.Shell") 18 | entry = shell.RegRead(theEntry) 19 | If Err.Number <> 0 then 20 | 'msgbox "FALSE: " & Err.Description 21 | Err.Clear 22 | regEntryExists = FALSE 23 | else 24 | Err.Clear 25 | 'msgbox "TRUE" 26 | regEntryExists = TRUE 27 | end if 28 | Set shell = Nothing 29 | End Function 30 | 31 | Function RegDeleteEntry(key) 32 | Set Sh = CreateObject("WScript.Shell") 33 | if regEntryExists(key) then 34 | Sh.RegDelete key 35 | msgbox "Key " & key & " was deleted." 36 | else 37 | msgbox "Key " & key & " does not exist." 38 | end if 39 | End Function 40 | 41 | RegDeleteEntry "HKCR\CLSID\{D9AD2502-2F93-4c0b-BC3C-20689232C3B0}\X0" 42 | RegDeleteEntry "HKCR\CLSID\{D7DDF8D4-92DE-4e76-9326-8746C446AAC4}\X0" 43 | -------------------------------------------------------------------------------- /mount.x: -------------------------------------------------------------------------------- 1 | /* @(#)mount.x 2.1 88/08/01 4.0 RPCSRC */ 2 | /* @(#)mount.x 1.2 87/09/18 Copyr 1987 Sun Micro */ 3 | 4 | /* 5 | * Sun RPC is a product of Sun Microsystems, Inc. and is provided for 6 | * unrestricted use provided that this legend is included on all tape 7 | * media and as a part of the software program in whole or part. Users 8 | * may copy or modify Sun RPC without charge, but are not authorized 9 | * to license or distribute it to anyone else except as part of a product or 10 | * program developed by the user. 11 | * 12 | * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE 13 | * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR 14 | * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. 15 | * 16 | * Sun RPC is provided with no support and without any obligation on the 17 | * part of Sun Microsystems, Inc. to assist in its use, correction, 18 | * modification or enhancement. 19 | * 20 | * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE 21 | * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC 22 | * OR ANY PART THEREOF. 23 | * 24 | * In no event will Sun Microsystems, Inc. be liable for any lost revenue 25 | * or profits or other special, indirect and consequential damages, even if 26 | * Sun has been advised of the possibility of such damages. 27 | * 28 | * Sun Microsystems, Inc. 29 | * 2550 Garcia Avenue 30 | * Mountain View, California 94043 31 | */ 32 | 33 | /* 34 | * Protocol description for the mount program 35 | */ 36 | 37 | 38 | const MNTPATHLEN = 1024; /* maximum bytes in a pathname argument */ 39 | const MNTNAMLEN = 255; /* maximum bytes in a name argument */ 40 | const FHSIZE = 32; /* size in bytes of a file handle */ 41 | 42 | /* 43 | * The fhandle is the file handle that the server passes to the client. 44 | * All file operations are done using the file handles to refer to a file 45 | * or a directory. The file handle can contain whatever information the 46 | * server needs to distinguish an individual file. 47 | */ 48 | typedef opaque fhandle[FHSIZE]; 49 | 50 | /* 51 | * If a status of zero is returned, the call completed successfully, and 52 | * a file handle for the directory follows. A non-zero status indicates 53 | * some sort of error. The status corresponds with UNIX error numbers. 54 | */ 55 | union fhstatus switch (unsigned fhs_status) { 56 | case 0: 57 | fhandle fhs_fhandle; 58 | default: 59 | void; 60 | }; 61 | 62 | /* 63 | * The type dirpath is the pathname of a directory 64 | */ 65 | typedef string dirpath; 66 | 67 | /* 68 | * The type name is used for arbitrary names (hostnames, groupnames) 69 | */ 70 | typedef string name; 71 | 72 | /* 73 | * A list of who has what mounted 74 | */ 75 | typedef struct mountbody *mountlist; 76 | struct mountbody { 77 | name ml_hostname; 78 | dirpath ml_directory; 79 | mountlist ml_next; 80 | }; 81 | 82 | /* 83 | * A list of netgroups 84 | */ 85 | typedef struct groupnode *groups; 86 | struct groupnode { 87 | name gr_name; 88 | groups gr_next; 89 | }; 90 | 91 | /* 92 | * A list of what is exported and to whom 93 | */ 94 | typedef struct exportnode *exports; 95 | struct exportnode { 96 | dirpath ex_dir; 97 | groups ex_groups; 98 | exports ex_next; 99 | }; 100 | 101 | /* v3 stuff added in by dancy. */ 102 | const FHSIZE3 = 64; /* Maximum bytes in a V3 file handle */ 103 | typedef opaque fhandle3; 104 | 105 | enum mountstat3 { 106 | MNT3_OK = 0, /* no error */ 107 | MNT3ERR_PERM = 1, /* Not owner */ 108 | MNT3ERR_NOENT = 2, /* No such file or directory */ 109 | MNT3ERR_IO = 5, /* I/O error */ 110 | MNT3ERR_ACCES = 13, /* Permission denied */ 111 | MNT3ERR_NOTDIR = 20, /* Not a directory */ 112 | MNT3ERR_INVAL = 22, /* Invalid argument */ 113 | MNT3ERR_NAMETOOLONG = 63, /* Filename too long */ 114 | MNT3ERR_NOTSUPP = 10004, /* Operation not supported */ 115 | MNT3ERR_SERVERFAULT = 10006 /* A failure on the server */ 116 | }; 117 | 118 | 119 | struct mountres3_ok { 120 | fhandle3 fhandle; 121 | int auth_flavors<>; 122 | }; 123 | 124 | union mountres3 switch (mountstat3 fhs_status) { 125 | case MNT3_OK: 126 | mountres3_ok mountinfo; 127 | default: 128 | void; 129 | }; 130 | 131 | /* 132 | * POSIX pathconf information 133 | */ 134 | struct ppathcnf { 135 | int pc_link_max; /* max links allowed */ 136 | short pc_max_canon; /* max line len for a tty */ 137 | short pc_max_input; /* input a tty can eat all at once */ 138 | short pc_name_max; /* max file name length (dir entry) */ 139 | short pc_path_max; /* max path name length (/x/y/x/.. ) */ 140 | short pc_pipe_buf; /* size of a pipe (bytes) */ 141 | char pc_vdisable; /* safe char to turn off c_cc[i] */ 142 | char pc_xxx; /* alignment padding; cc_t == char */ 143 | short pc_mask[2]; /* validity and boolean bits */ 144 | }; 145 | 146 | 147 | 148 | program MOUNTPROG { 149 | /* 150 | * Version one of the mount protocol communicates with version two 151 | * of the NFS protocol. The only connecting point is the fhandle 152 | * structure, which is the same for both protocols. 153 | */ 154 | version MOUNTVERS { 155 | /* 156 | * Does no work. It is made available in all RPC services 157 | * to allow server response testing and timing 158 | */ 159 | void 160 | MOUNTPROC_NULL(void) = 0; 161 | 162 | /* 163 | * If fhs_status is 0, then fhs_fhandle contains the 164 | * file handle for the directory. This file handle may 165 | * be used in the NFS protocol. This procedure also adds 166 | * a new entry to the mount list for this client mounting 167 | * the directory. 168 | * Unix authentication required. 169 | */ 170 | fhstatus 171 | MOUNTPROC_MNT(dirpath) = 1; 172 | 173 | /* 174 | * Returns the list of remotely mounted filesystems. The 175 | * mountlist contains one entry for each hostname and 176 | * directory pair. 177 | */ 178 | mountlist 179 | MOUNTPROC_DUMP(void) = 2; 180 | 181 | /* 182 | * Removes the mount list entry for the directory 183 | * Unix authentication required. 184 | */ 185 | void 186 | MOUNTPROC_UMNT(dirpath) = 3; 187 | 188 | /* 189 | * Removes all of the mount list entries for this client 190 | * Unix authentication required. 191 | */ 192 | void 193 | MOUNTPROC_UMNTALL(void) = 4; 194 | 195 | /* 196 | * Returns a list of all the exported filesystems, and which 197 | * machines are allowed to import it. 198 | */ 199 | exports 200 | MOUNTPROC_EXPORT(void) = 5; 201 | 202 | /* 203 | * Identical to MOUNTPROC_EXPORT above 204 | */ 205 | exports 206 | MOUNTPROC_EXPORTALL(void) = 6; 207 | } = 1; 208 | /* 209 | * Version two of the mount protocol communicates with version two 210 | * of the NFS protocol. 211 | * The only difference from version one is the addition of a POSIX 212 | * pathconf call. 213 | */ 214 | version MOUNTVERS_POSIX { 215 | /* 216 | * Does no work. It is made available in all RPC services 217 | * to allow server reponse testing and timing 218 | */ 219 | void 220 | MOUNTPROC_NULL(void) = 0; 221 | 222 | /* 223 | * If fhs_status is 0, then fhs_fhandle contains the 224 | * file handle for the directory. This file handle may 225 | * be used in the NFS protocol. This procedure also adds 226 | * a new entry to the mount list for this client mounting 227 | * the directory. 228 | * Unix authentication required. 229 | */ 230 | fhstatus 231 | MOUNTPROC_MNT(dirpath) = 1; 232 | 233 | /* 234 | * Returns the list of remotely mounted filesystems. The 235 | * mountlist contains one entry for each hostname and 236 | * directory pair. 237 | */ 238 | mountlist 239 | MOUNTPROC_DUMP(void) = 2; 240 | 241 | /* 242 | * Removes the mount list entry for the directory 243 | * Unix authentication required. 244 | */ 245 | void 246 | MOUNTPROC_UMNT(dirpath) = 3; 247 | 248 | /* 249 | * Removes all of the mount list entries for this client 250 | * Unix authentication required. 251 | */ 252 | void 253 | MOUNTPROC_UMNTALL(void) = 4; 254 | 255 | /* 256 | * Returns a list of all the exported filesystems, and which 257 | * machines are allowed to import it. 258 | */ 259 | exports 260 | MOUNTPROC_EXPORT(void) = 5; 261 | 262 | /* 263 | * Identical to MOUNTPROC_EXPORT above 264 | */ 265 | exports 266 | MOUNTPROC_EXPORTALL(void) = 6; 267 | 268 | /* 269 | * POSIX pathconf info (Sun hack) 270 | */ 271 | ppathcnf 272 | MOUNTPROC_PATHCONF(dirpath) = 7; 273 | } = 2; 274 | 275 | version MOUNT_V3 { 276 | void MOUNTPROC3_NULL(void) = 0; 277 | mountres3 MOUNTPROC3_MNT(dirpath) = 1; 278 | mountlist MOUNTPROC3_DUMP(void) = 2; 279 | void MOUNTPROC3_UMNT(dirpath) = 3; 280 | void MOUNTPROC3_UMNTALL(void) = 4; 281 | exports MOUNTPROC3_EXPORT(void) = 5; 282 | } = 3; 283 | 284 | } = 100005; 285 | 286 | 287 | -------------------------------------------------------------------------------- /mountd.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (in-package :mount) 5 | 6 | (sunrpc:def-rpc-program (MNT 100005 :port *mountd-port-number*) 7 | ( 8 | (1 ;; version 9 | (0 mountproc-null void void) 10 | (1 mountproc-mnt dirpath fhstatus) 11 | (2 mountproc-dump void mountlist) 12 | (3 mountproc-umnt dirpath void) 13 | (4 mountproc-umntall void void) 14 | (5 mountproc-export void exports) 15 | (6 mountproc-exportall void exports) 16 | ) 17 | (2 ;; version 18 | (0 mountproc-null void void) 19 | (1 mountproc-mnt dirpath fhstatus) 20 | (2 mountproc-dump void mountlist) 21 | (3 mountproc-umnt dirpath void) 22 | (4 mountproc-umntall void void) 23 | (5 mountproc-export void exports) 24 | (6 mountproc-exportall void exports) 25 | (7 mountproc-pathconf dirpath ppathcnf) 26 | ) 27 | (3 ;; version 28 | (0 mountproc3-null void void) 29 | (1 mountproc3-mnt dirpath mountres3) 30 | (2 mountproc3-dump void mountlist) 31 | (3 mountproc3-umnt dirpath void) 32 | (4 mountproc3-umntall void void) 33 | (5 mountproc3-export void exports) 34 | ) 35 | )) 36 | 37 | 38 | (defparameter *mounts* nil) 39 | 40 | ;;; Override the automatically generated xdr-fhandle* functions. 41 | (without-redefinition-warnings 42 | (defun xdr-fhandle (xdr &optional arg) 43 | (user::xdr-fhandle xdr 2 arg)) 44 | 45 | (defun xdr-fhandle3 (xdr &optional arg) 46 | (user::xdr-fhandle xdr 3 arg))) 47 | 48 | ;;;; Procedures 49 | 50 | (defun mountproc-null (arg vers peer cbody) 51 | (declare (ignore arg cbody)) 52 | (if *mountd-debug* 53 | (user::logit-stamp "MNT~a: ~a: NULL~%" vers (sunrpc:peer-dotted peer)))) 54 | 55 | (defun mountproc3-null (arg vers peer cbody) 56 | (mountproc-null arg vers peer cbody)) 57 | 58 | ;; Note that DIRPATH is allowed to name a file or directory beneath an export. 59 | (defun mountproc-mnt-common (dirpath vers peer) 60 | "Returns the file handle (fh struct) corresponding to DIRFH if 61 | successful. Otherwise returns an NFS error code" 62 | (if *mountd-debug* 63 | (user::logit-stamp "MNT~d: ~a: MOUNT ~a " 64 | vers (sunrpc:peer-dotted peer) dirpath)) 65 | (multiple-value-bind (exp tail) 66 | (user::locate-nearest-export-by-nfs-path dirpath) 67 | (if* (null exp) 68 | then (if *mountd-debug* (user::logit "==> Denied (no such export).~%")) 69 | gen-nfs:*nfserr-noent* 70 | elseif (not (user::export-host-access-allowed-p 71 | exp (sunrpc:rpc-peer-addr peer))) 72 | then (if *mountd-debug* 73 | (user::logit "==> Denied (host not allowed).~%")) 74 | gen-nfs:*nfserr-acces* 75 | else (let ((fh (user::get-fhandle-for-path tail exp))) 76 | (if* fh 77 | then (if *mountd-debug* (user::logit "==> Accepted.~%")) 78 | (pushnew (list (sunrpc:rpc-peer-addr peer) dirpath) 79 | *mounts* 80 | :test #'equalp) 81 | fh 82 | else (if *mountd-debug* (user::logit "==> Not found.~%")) 83 | gen-nfs:*nfserr-noent*))))) 84 | 85 | (defun mountproc-mnt (dirpath vers peer cbody) 86 | (declare (ignore cbody)) 87 | (let ((fh (mountproc-mnt-common dirpath vers peer))) 88 | (if* (numberp fh) 89 | then (make-fhstatus :fhs-status fh) ;; error code 90 | else (make-fhstatus :fhs-status 0 :fhs-fhandle fh)))) 91 | 92 | (defun mountproc3-mnt (dirpath vers peer cbody) 93 | (declare (ignore cbody)) 94 | (let ((fh (mountproc-mnt-common dirpath vers peer))) 95 | (if* (numberp fh) 96 | then (make-mountres3 :fhs-status fh) ;; error code 97 | else (make-mountres3 :fhs-status *mnt3-ok* 98 | :mountinfo 99 | (make-mountres3-ok :fhandle fh 100 | :auth-flavors 101 | (list sunrpc:*auth-unix*)))))) 102 | 103 | (defun mountproc-dump (arg vers peer cbody) 104 | (declare (ignore arg cbody)) 105 | (if *mountd-debug* 106 | (user::logit-stamp "MNT~d: ~a: DUMP~%" vers (sunrpc:peer-dotted peer))) 107 | (let (res) 108 | (dolist (pair *mounts*) 109 | (setf res 110 | (make-mountbody :ml-hostname (socket:ipaddr-to-dotted (first pair)) 111 | :ml-directory (second pair) 112 | :ml-next res))) 113 | res)) 114 | 115 | (defun mountproc3-dump (arg vers peer cbody) 116 | (mountproc-dump arg vers peer cbody)) 117 | 118 | (defun mountproc-umnt (dirpath vers peer cbody) 119 | (declare (ignore cbody)) 120 | (if *mountd-debug* 121 | (user::logit-stamp "MNT~d: ~a: UMOUNT ~a~%" vers (sunrpc:peer-dotted peer) dirpath)) 122 | (setf *mounts* 123 | (delete (list (sunrpc:rpc-peer-addr peer) dirpath) 124 | *mounts* 125 | :test #'equalp))) 126 | 127 | (defun mountproc3-umnt (dirpath vers peer cbody) 128 | (mountproc-umnt dirpath vers peer cbody)) 129 | 130 | (defun mountproc-umntall (arg vers peer cbody) 131 | (declare (ignore arg cbody)) 132 | (if *mountd-debug* 133 | (user::logit-stamp "MNT~d: ~a: UMOUNT ALL~%" vers (sunrpc:peer-dotted peer))) 134 | (setf *mounts* 135 | (delete (sunrpc:rpc-peer-addr peer) *mounts* :key #'first))) 136 | 137 | (defun mountproc3-umntall (arg vers peer cbody) 138 | (mountproc-umntall arg vers peer cbody)) 139 | 140 | (defun mountproc-export (arg vers peer cbody) 141 | (declare (ignore arg cbody)) 142 | 143 | (when mount:*showmount-disabled* 144 | (when *mountd-debug* 145 | (user::logit-stamp "MNT~d: ~A: EXPORT is disabled via config.~%" vers (sunrpc:peer-dotted peer))) 146 | (return-from mountproc-export)) 147 | 148 | (if *mountd-debug* 149 | (user::logit-stamp "MNT~d: ~a: EXPORT~%" vers (sunrpc:peer-dotted peer))) 150 | 151 | (let (res) 152 | (user::do-exports (export-name export) 153 | (setf res 154 | (make-exportnode 155 | :ex-dir export-name 156 | :ex-groups (let (grp) 157 | (dolist (g (user::nfs-export-hosts-allow export)) 158 | (setf grp 159 | (make-groupnode 160 | :gr-name (user::network-address-to-printable-string g) 161 | :gr-next grp)))) 162 | :ex-next res))) 163 | res)) 164 | 165 | (defun mountproc3-export (arg vers peer cbody) 166 | (mountproc-export arg vers peer cbody)) 167 | 168 | (defun mountproc-exportall (arg vers peer cbody) 169 | (mountproc-export arg vers peer cbody)) 170 | 171 | (defconstant *pc-error* 0) 172 | (defconstant *pc-link-max* 1) 173 | (defconstant *pc-max-canon* 2) 174 | (defconstant *pc-max-input* 3) 175 | (defconstant *pc-name-max* 4) 176 | (defconstant *pc-path-max* 5) 177 | (defconstant *pc-pipe-buf* 6) 178 | (defconstant *pc-no-trunc* 7) 179 | (defconstant *pc-vdisable* 8) 180 | (defconstant *pc-chown-restricted* 9) 181 | 182 | (defun mountproc-pathconf (dirpath vers peer cbody) 183 | (declare (ignore cbody)) 184 | (if* *mountd-debug* 185 | then (user::logit-stamp "MNT~d: ~a: PATHCONF ~a~%" vers (sunrpc:peer-dotted peer) dirpath)) 186 | 187 | ;; Return information in the same way that Solaris 9 does 188 | (make-ppathcnf :pc-link-max 1023 ;; NTFS limit 189 | :pc-max-canon 0 :pc-max-input 0 190 | :pc-name-max 255 :pc-path-max 255 191 | :pc-pipe-buf 0 :pc-vdisable 0 :pc-xxx 0 192 | :pc-mask (list 193 | (logior 194 | ;; Indicate which fields are invalid 195 | (ash 1 *pc-max-canon*) 196 | (ash 1 *pc-max-input*) 197 | (ash 1 *pc-pipe-buf*) 198 | (ash 1 *pc-vdisable*) 199 | ;; And indicate behavior 200 | (ash 1 *pc-no-trunc*) 201 | (ash 1 *pc-chown-restricted*)) 202 | 0))) 203 | 204 | ;;;;;;;;;;;;;;;;;;;; 205 | 206 | (eval-when (compile load eval) 207 | (export '(*mountd-debug* *mountd-port-number* MNT))) 208 | 209 | -------------------------------------------------------------------------------- /nfs-common.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (in-package :user) 5 | 6 | (eval-when (compile load eval) 7 | (require :osi) 8 | (use-package :excl.osi) 9 | (use-package :gen-nfs)) 10 | 11 | ;; NOTE: the form of the version *must* be a.b.c. If you're starting 12 | ;; a new release, say 6.0, then use 6.0.0. For betas, use 13 | ;; something like 6.2.0-beta3. 14 | (defvar *nfsd-version* "7.1.0") 15 | (defvar *nfsd-long-version* 16 | (format nil "~a (NFSv2/NFSv3)" *nfsd-version*)) 17 | (load (merge-pathnames "commit-id.cl" *load-pathname*)) 18 | 19 | ;; max (65535), minus 8 bytes for UDP header, minus 20 bytes for IPv4 header. 20 | ;; XREF: https://en.wikipedia.org/wiki/User_Datagram_Protocol#Packet_structure 21 | (defconstant *max-udp-datagram-size* (- 65535 8 20)) ;; = 65507 22 | 23 | ;; Filesystem allocation unit size. Only used by statfs procedure. 24 | ;; See discussion in spr39245 for why this was changed from 8192. 25 | (defconstant *blocksize* 512) 26 | 27 | (defconstant *nfs-debug-read* #x00000001) 28 | (defconstant *nfs-debug-write* #x00000002) 29 | (defconstant *nfs-debug-readdir* #x00000004) ;; includes readdirplus 30 | (defconstant *nfs-debug-getattr* #x00000008) 31 | (defconstant *nfs-debug-setattr* #x00000010) 32 | (defconstant *nfs-debug-lookup* #x00000020) 33 | (defconstant *nfs-debug-access* #x00000040) 34 | (defconstant *nfs-debug-create* #x00000080) 35 | (defconstant *nfs-debug-mkdir* #x00000100) 36 | (defconstant *nfs-debug-rmdir* #x00000200) 37 | (defconstant *nfs-debug-remove* #x00000400) 38 | (defconstant *nfs-debug-rename* #x00000800) 39 | (defconstant *nfs-debug-fsstat* #x00001000) 40 | (defconstant *nfs-debug-fsinfo* #x00002000) 41 | (defconstant *nfs-debug-pathconf* #x00004000) 42 | (defconstant *nfs-debug-commit* #x00008000) 43 | (defconstant *nfs-debug-null* #x00010000) 44 | (defconstant *nfs-debug-statfs* #x00020000) 45 | (defconstant *nfs-debug-link* #x00040000) 46 | (defconstant *nfs-debug-symlink* #x00080000) 47 | (defconstant *nfs-debug-readlink* #x00100000) 48 | (defconstant *nfs-debug-mknod* #x00200000) 49 | 50 | (defmacro nfs-debug-filter-on (type) 51 | (if (eq type 'readdirplus) 52 | (setf type 'readdir)) 53 | (let ((constant (intern (format nil "*nfs-debug-~a*" type)))) 54 | `(and *nfs-debug* (/= 0 (logand *nfs-debug-filter* ,constant))))) 55 | 56 | (defun map-errno-to-nfs-error-code (errno) 57 | (case errno 58 | (#.*enoent* *nfserr-noent*) 59 | (#.*eio* *nfserr-io*) 60 | (#.*eacces* *nfserr-acces*) 61 | (#.*enfile* *nfserr-acces*) 62 | (#.*enotempty* *nfserr-notempty*) 63 | (#.*eexist* *nfserr-exist*) 64 | (#.*einval* *nfserr-inval*) 65 | (#.*enospc* *nfserr-nospc*) 66 | ;; very general... avoid. For v3, should should be 67 | ;; *nfserr-serverfault* 68 | (t *nfserr-io*))) 69 | 70 | ;; Needed for proper error reporting. 71 | (eval-when (compile load eval) 72 | (setf excl::*strict-probe-file* t)) 73 | 74 | (defun roundup (value multiple) 75 | (let ((mod (mod value multiple))) 76 | (+ value (if (> mod 0) (- multiple mod) 0)))) 77 | 78 | ;;; return how many blocks are required to contain 'value' items 79 | ;;; given a particular blocksize 80 | (defun howmany (value blocksize) 81 | (/ (roundup value blocksize) blocksize)) 82 | 83 | (define-compiler-macro howmany (value blocksize &whole whole &environment env) 84 | (flet ((power-of-two-p (value) 85 | (zerop (nth-value 1 (truncate (log value 2)))))) 86 | (let ((cv 87 | (and (constantp blocksize env) (sys:constant-value blocksize env)))) 88 | (if* (and cv (power-of-two-p cv)) 89 | then (setf blocksize cv) 90 | (let ((v (gensym))) 91 | `(let ((,v ,value)) 92 | (if* (fixnump ,v) 93 | then (let () 94 | (declare (fixnum ,v)) 95 | (ash (logand (+ ,v ,(1- blocksize)) 96 | (lognot ,(1- blocksize))) 97 | ,(- (truncate (log blocksize 2))))) 98 | else (ash (logand (+ ,v ,(1- blocksize)) 99 | (lognot ,(1- blocksize))) 100 | ,(- (truncate (log blocksize 2))))))) 101 | else whole)))) 102 | 103 | ;; debugmain sets this to nil 104 | (defparameter *exit-on-bailout* t) 105 | 106 | (defmacro bailout (format &rest format-args) 107 | (let ((complaint (gensym "complaint"))) 108 | `(let ((,complaint (format nil ,format ,@format-args))) 109 | (logit-stamp "~a" ,complaint) 110 | (console-control :close t :show t) 111 | (if* *exit-on-bailout* 112 | then (exit 1) 113 | else (error "~a" ,complaint))))) 114 | 115 | (ff:def-foreign-call MoveFileExA ((from (* :char)) 116 | (to (* :char)) 117 | (flags :int)) 118 | :strings-convert t 119 | :returning :boolean 120 | :error-value :os-specific) 121 | 122 | (ff:def-foreign-call MoveFileExW ((from (* :void)) 123 | (to (* :void)) 124 | (flags :int)) 125 | :strings-convert nil 126 | :returning :boolean 127 | :error-value :os-specific) 128 | 129 | (defconstant MOVEFILE_REPLACE_EXISTING 1) 130 | 131 | ;; This function will accept pathnames but it will not translate 132 | ;; logical pathnames. The caller is responsible for that. 133 | (defun my-rename (from to &key unicode) 134 | (if (pathnamep from) 135 | (setf from (namestring from))) 136 | (if (pathnamep to) 137 | (setf to (namestring to))) 138 | 139 | (multiple-value-bind (success winerr) 140 | (if* unicode 141 | then (MoveFileExW from to MOVEFILE_REPLACE_EXISTING) 142 | else (MoveFileExA from to MOVEFILE_REPLACE_EXISTING)) 143 | (if* success 144 | then t 145 | else (excl.osi:perror (excl.osi::win_err_to_errno winerr) 146 | "rename failed")))) 147 | -------------------------------------------------------------------------------- /nfs-log.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | ;; Logging support 5 | 6 | (in-package :user) 7 | 8 | (defvar *log-stream* nil) 9 | (defvar *log-stream-lock* (mp:make-process-lock) 10 | "A gate for use in logging.") 11 | (defvar *program-mode* nil) ;; nil or :service 12 | (defvar *console-sockets* nil) 13 | (defvar *console-sockets-lock* (mp:make-process-lock)) 14 | ;;(defvar *log-rotation-current-count* 0) ; moved to config-defs 15 | ;;(defvar *log-file* "sys:nfsdebug-~D.txt") ; moved to config-defs 16 | (defvar *nfs-debug-stream* nil) 17 | 18 | (defun log-rotateable (string) 19 | "Returns true if the *log-stream* will need rotation to write 20 | a given string." 21 | (and (not (= 0 *log-rotation-file-size*)) 22 | (< (* *log-rotation-file-size* 23 | *log-rotation-file-size-magnitude*) 24 | (+ (file-length *log-stream*) 25 | (length string))))) 26 | ;;defun make-log-rotation-name ; moved to config-defs 27 | 28 | (defun rotate-log () 29 | "Rotates *log-stream*" 30 | ;; Setup the next log file count. 31 | (write-string "Rotating away from this logfile." *log-stream*) 32 | (incf *log-rotation-current-count*) 33 | (when (<= *log-rotation-file-count* 34 | *log-rotation-current-count*) 35 | (setf *log-rotation-current-count* 0)) 36 | 37 | ;; Open up the new log file 38 | (let ((new-log (open (make-log-rotation-name 39 | *log-rotation-current-count*) 40 | :direction :output 41 | :if-does-not-exist :create 42 | :if-exists :supersede 43 | :external-format :utf8))) 44 | (when (and new-log 45 | (open-stream-p new-log)) 46 | ;; If streams are open, flush and close. 47 | (mp:with-process-lock (*log-stream-lock*) 48 | (flet ((close-stream (stream) 49 | (when (open-stream-p stream) 50 | (finish-output stream) 51 | (close stream :abort nil)))) 52 | ;; bug22497: 53 | ;; Close *log-stream* first, in case we're in non-service 54 | ;; mode, because otherwise an error results. 55 | ;; Reported by John Peterson. 56 | ;; https://github.com/franzinc/nfs/pull/7 57 | (close-stream *log-stream*) 58 | (close-stream *nfs-debug-stream*)) 59 | ;; If we are running as a service then use the new file in both places. 60 | (if* (eq *program-mode* :service) 61 | then (setf *log-stream* new-log 62 | *nfs-debug-stream* new-log) 63 | (logit-stamp "~&Rotated logfile successfully to ~A~%" 64 | (file-namestring new-log)) 65 | ;; Otherwise we setup the log-stream to be debug plus terminal io. 66 | else (setf *nfs-debug-stream* new-log 67 | *log-stream* (make-broadcast-stream *initial-terminal-io* 68 | *nfs-debug-stream*))))))) 69 | 70 | (defun logit-1 (string) 71 | (mp:with-process-lock (*log-stream-lock*) 72 | (when *log-stream* 73 | (when (log-rotateable string) 74 | (rotate-log)) 75 | (write-string string *log-stream*) 76 | (force-output *log-stream*))) 77 | 78 | (when (eq *program-mode* :service) 79 | (mp:with-process-lock (*console-sockets-lock*) 80 | (let (ok) 81 | (dolist (sock *console-sockets*) 82 | (if* (null (ignore-errors 83 | (progn 84 | (write-string string sock) 85 | (finish-output sock) 86 | (setf ok t)))) 87 | then ;; Communication w/ the console socket failed. 88 | (close sock :abort t) 89 | (setf *console-sockets* 90 | (delete sock *console-sockets*)))) 91 | (if (not ok) 92 | (log-buffer-add string)))))) 93 | 94 | (defun logit (format-string &rest format-args) 95 | (logit-1 (apply #'format nil format-string format-args))) 96 | 97 | (defun logit-stamp (format-string &rest format-args) 98 | (multiple-value-bind (sec min hour day month year ignore usec) 99 | (get-decoded-time) 100 | (declare (ignore ignore)) 101 | (multiple-value-setq (ignore usec) (excl::acl-internal-real-time)) 102 | (logit "~d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d.~3,'0d| " 103 | year month day hour min sec (truncate usec 1000)) 104 | (apply #'logit format-string format-args))) 105 | 106 | (eval-when (compile eval load) 107 | (require :streamc) ;; for make-broadcast-stream 108 | ) 109 | 110 | ;; defun find-latest-log-file ; moved to config-defs 111 | 112 | (defun setup-logging (&optional reopen) 113 | (mp:with-process-lock (*log-stream-lock*) 114 | (when reopen 115 | (when *nfs-debug-stream* (close *nfs-debug-stream*)) 116 | (setf *log-stream* nil)) 117 | 118 | (let ((latest (find-latest-log-file))) 119 | (when (null *log-stream*) 120 | (setf *nfs-debug-stream* 121 | (open latest 122 | :direction :output 123 | :external-format :utf8 124 | :if-exists :append 125 | :if-does-not-exist :create)) 126 | 127 | (if* (eq *program-mode* :service) 128 | then (setf *log-stream* *nfs-debug-stream*) 129 | (mp:process-run-function "Console server" #'console-server) 130 | else (setf *log-stream*(make-broadcast-stream *initial-terminal-io* 131 | *nfs-debug-stream*))) 132 | (logit-stamp "Log file: ~a~%" 133 | (translate-logical-pathname latest)))))) 134 | 135 | (eval-when (compile load eval) 136 | (defconstant *nfs-log-limit* 32768)) ;; # of strings. Use a power of 2 137 | 138 | (defparameter *log-buffer* (make-array *nfs-log-limit*)) 139 | (defvar *log-buffer-lock* (mp:make-process-lock)) 140 | 141 | (defparameter *log-buffer-start* 0) ;; where next retrieve will occur 142 | (defparameter *log-buffer-end* 0) ;; where next store will occur 143 | 144 | (defun log-buffer-add (string) 145 | (declare (optimize (speed 3))) 146 | (macrolet ((next-pos (val) 147 | `(logand (the fixnum (1+ ,val)) (1- *nfs-log-limit*)))) 148 | (mp:with-process-lock (*log-buffer-lock*) 149 | (let* ((start *log-buffer-start*) 150 | (end *log-buffer-end*) 151 | (newend (next-pos end))) 152 | (declare (fixnum start end newend)) 153 | 154 | (setf *log-buffer-end* newend) 155 | (setf (aref (the (simple-array t (*)) *log-buffer*) end) string) 156 | 157 | (if (eq newend start) 158 | (setf *log-buffer-start* (next-pos start))))))) 159 | 160 | (defvar *console-listener* nil) 161 | 162 | (defun console-server () 163 | (unwind-protect 164 | (let ((sock (socket:make-socket :connect :passive 165 | :local-host "127.0.0.1"))) 166 | (setf *console-listener* sock) 167 | (loop 168 | (let ((cli (ignore-errors (socket:accept-connection sock)))) 169 | (when cli 170 | (mp:with-process-lock (*console-sockets-lock*) 171 | (push cli *console-sockets*) 172 | (console-server-1 cli)))))) 173 | (close *console-listener*) 174 | (setf *console-listener* nil))) 175 | 176 | ;; Dump any buffers log data 177 | (defun console-server-1 (sock) 178 | (declare (optimize (speed 3))) 179 | (mp:with-process-lock (*log-buffer-lock*) 180 | (let ((start *log-buffer-start*) 181 | (end *log-buffer-end*) 182 | (buf *log-buffer*)) 183 | (declare (fixnum start end) 184 | (type (simple-array t (*)) buf)) 185 | (handler-case 186 | (progn 187 | (while (not (eq start end)) 188 | (write-string (aref buf start) sock) 189 | (incf start)) 190 | (finish-output sock)) 191 | (error (c) 192 | (declare (ignore c)) 193 | ;; Communication failure, presumably. Close down. 194 | (close sock :abort t) 195 | (setf *console-sockets* (delete sock *console-sockets*)))) 196 | (setf *log-buffer-start* start)))) 197 | 198 | (defun get-console-port () 199 | (let ((res 200 | (ignore-errors 201 | (sunrpc:with-rpc-client (cli "127.0.01" #.gen-nfs:*nfs-program* 2 :udp) 202 | (sunrpc:callrpc cli 102 nil nil :outproc #'xdr:xdr-int))))) 203 | (if (and res (not (zerop res))) 204 | res))) 205 | 206 | (ff:def-foreign-call CreateMutexA () :strings-convert t 207 | :error-value :os-specific) 208 | 209 | (defun console (hide) 210 | ;; Make sure only one instance runs in this session. 211 | (multiple-value-bind (handle err) 212 | (CreateMutexA 0 0 "Allegro NFS Console") 213 | (declare (ignore handle)) 214 | (if (not (zerop err)) 215 | (exit 0))) 216 | 217 | (console-control :tray-exit t :close :hide 218 | :show (if hide nil t)) 219 | 220 | (set-window-title "Allegro NFS Console") 221 | 222 | (let (port sock) 223 | (tagbody 224 | top 225 | (setf port (get-console-port)) 226 | (if* (null port) 227 | then ;;(format t "no console port~%") 228 | (sleep 5) 229 | (go top)) 230 | 231 | ;;(format t "console port is ~d~%" port) 232 | 233 | (setf sock (ignore-errors (socket:make-socket :remote-host "127.0.0.1" 234 | :remote-port port))) 235 | (if* (null sock) 236 | then ;;(format t "make-socket to port ~d failed.~%" port) 237 | (sleep 5) 238 | (go top)) 239 | 240 | (format t "Allegro NFS v~a running.~%" *nfsd-version*) 241 | 242 | (unwind-protect 243 | (let ((buf (make-string 65536)) 244 | got) 245 | (loop 246 | (setf got (ignore-errors (read-vector buf sock))) 247 | (if* (or (null got) (zerop got)) 248 | then ;;(format t "EOF or socket error.~%") 249 | #+ignore 250 | (go top) 251 | ;; Terminate when service exits 252 | (exit 0) 253 | ) 254 | (write-vector buf *initial-terminal-io* :end got) 255 | (finish-output *initial-terminal-io*))) 256 | ;; cleanup 257 | (format t "Allegro NFS stopped.~%") 258 | (close sock :abort t))))) 259 | -------------------------------------------------------------------------------- /nfs-shared.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (in-package :user) 5 | 6 | ;; This file contains stuff that is shared between the nfs server code 7 | ;; and the configuration app code. 8 | 9 | (eval-when (compile eval load) 10 | (require :regexp2) 11 | (require :shell) 12 | (use-package :excl.shell)) 13 | 14 | (defun cleanup-dir (dir) 15 | ;; n: => n:\ 16 | ;; n:\src\ => n:\src 17 | ;; \\foo\bar => \\foo\bar\ 18 | 19 | ;; convert forward slashes to backslashes 20 | (setq dir (namestring (pathname dir))) 21 | 22 | (if* (=~ "^[A-Za-z]:$" dir) 23 | then (+= dir "\\") 24 | elseif (=~ "([A-Za-z]:.+)\\\\$" dir) 25 | then $1 26 | elseif (=~ "(\\\\\\\\[^\\\\]+\\\\[^\\\\]+)$" dir) 27 | then (+= $1 "\\") 28 | else dir)) 29 | 30 | #+ignore 31 | (defun test-cleanup-dir () 32 | (let ((cases '( 33 | ;; (expected-result input) 34 | ("n:\\" "n:") 35 | ("n:\\" "n:/") 36 | ("n:\\" "n:\\") 37 | 38 | ("n:\\src" "n:/src") 39 | ("n:\\src" "n:\\src") 40 | ("n:\\src" "n:\\src\\") 41 | ("n:\\src" "n:/src/") 42 | 43 | ("\\\\server\\share\\" "\\\\server\\share") 44 | ("\\\\server\\share\\" "\\\\server\\share\\") 45 | ("\\\\server\\share\\" "//server/share") 46 | ("\\\\server\\share\\" "//server/share/") 47 | ))) 48 | (loop for (expected input) in cases 49 | do (let ((got (cleanup-dir input))) 50 | (when (string/= got expected) 51 | (error "(cleanup-dir ~s): expected ~s, got ~s." 52 | input expected got)))))) 53 | -------------------------------------------------------------------------------- /nfs.cfg.default: -------------------------------------------------------------------------------- 1 | ( 2 | ;; lists must be defined first 3 | 4 | ;; defaults 5 | (define-host-list "all" t) 6 | (define-user-list "everyone" t) 7 | (define-user-list "root" 0) 8 | ) 9 | 10 | -------------------------------------------------------------------------------- /nfs.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/nfs/6df1f6970274e7dd02f0010a7a170369fc09834c/nfs.ico -------------------------------------------------------------------------------- /nlm.x: -------------------------------------------------------------------------------- 1 | /* 2 | * Network lock manager protocol definition 3 | * Copyright (C) 1986 Sun Microsystems, Inc. 4 | * 5 | * protocol used between local lock manager and remote lock manager 6 | */ 7 | 8 | const MAXNETOBJ_SZ = 1024; 9 | 10 | typedef opaque netobj; 11 | 12 | /* 13 | * status of a call to the lock manager 14 | */ 15 | enum nlm_stats { 16 | nlm_granted = 0, 17 | nlm_denied = 1, 18 | nlm_denied_nolocks = 2, 19 | nlm_blocked = 3, 20 | nlm_denied_grace_period = 4 21 | }; 22 | 23 | struct nlm_holder { 24 | bool exclusive; 25 | int svid; 26 | netobj oh; 27 | unsigned l_offset; 28 | unsigned l_len; 29 | }; 30 | 31 | union nlm_testrply switch (nlm_stats stat) { 32 | case nlm_denied: 33 | struct nlm_holder holder; 34 | default: 35 | void; 36 | }; 37 | 38 | struct nlm_stat { 39 | nlm_stats stat; 40 | }; 41 | 42 | struct nlm_res { 43 | netobj cookie; 44 | nlm_stat stat; 45 | }; 46 | 47 | struct nlm_testres { 48 | netobj cookie; 49 | nlm_testrply stat; 50 | }; 51 | 52 | struct nlm_lock { 53 | string caller_name; 54 | netobj fh; /* identify a file */ 55 | netobj oh; /* identify owner of a lock */ 56 | int svid; /* generated from pid for svid */ 57 | unsigned l_offset; 58 | unsigned l_len; 59 | }; 60 | 61 | struct nlm_lockargs { 62 | netobj cookie; 63 | bool block; 64 | bool exclusive; 65 | struct nlm_lock alock; 66 | bool reclaim; /* used for recovering locks */ 67 | int state; /* specify local status monitor state */ 68 | }; 69 | 70 | struct nlm_cancargs { 71 | netobj cookie; 72 | bool block; 73 | bool exclusive; 74 | struct nlm_lock alock; 75 | }; 76 | 77 | struct nlm_testargs { 78 | netobj cookie; 79 | bool exclusive; 80 | struct nlm_lock alock; 81 | }; 82 | 83 | struct nlm_unlockargs { 84 | netobj cookie; 85 | struct nlm_lock alock; 86 | }; 87 | 88 | 89 | #ifdef RPC_HDR 90 | %/* 91 | % * The following enums are actually bit encoded for efficient 92 | % * boolean algebra.... DON'T change them..... 93 | % */ 94 | #endif 95 | enum fsh_mode { 96 | fsm_DN = 0, /* deny none */ 97 | fsm_DR = 1, /* deny read */ 98 | fsm_DW = 2, /* deny write */ 99 | fsm_DRW = 3 /* deny read/write */ 100 | }; 101 | 102 | enum fsh_access { 103 | fsa_NONE = 0, /* for completeness */ 104 | fsa_R = 1, /* read only */ 105 | fsa_W = 2, /* write only */ 106 | fsa_RW = 3 /* read/write */ 107 | }; 108 | 109 | struct nlm_share { 110 | string caller_name; 111 | netobj fh; 112 | netobj oh; 113 | fsh_mode mode; 114 | fsh_access access; 115 | }; 116 | 117 | struct nlm_shareargs { 118 | netobj cookie; 119 | nlm_share share; 120 | bool reclaim; 121 | }; 122 | 123 | struct nlm_shareres { 124 | netobj cookie; 125 | nlm_stats stat; 126 | int sequence; 127 | }; 128 | 129 | struct nlm_notify { 130 | string name; 131 | long state; 132 | }; 133 | 134 | #ifdef RPC_HDR 135 | %/* definitions for NLM version 4 */ 136 | #endif 137 | enum nlm4_stats { 138 | nlm4_granted = 0, 139 | nlm4_denied = 1, 140 | nlm4_denied_nolock = 2, 141 | nlm4_blocked = 3, 142 | nlm4_denied_grace_period = 4, 143 | nlm4_deadlck = 5, 144 | nlm4_rofs = 6, 145 | nlm4_stale_fh = 7, 146 | nlm4_fbig = 8, 147 | nlm4_failed = 9 148 | }; 149 | 150 | struct nlm4_stat { 151 | nlm4_stats stat; 152 | }; 153 | 154 | struct nlm4_holder { 155 | bool exclusive; 156 | u_int32_t svid; 157 | netobj oh; 158 | u_int64_t l_offset; 159 | u_int64_t l_len; 160 | }; 161 | 162 | struct nlm4_lock { 163 | string caller_name; 164 | netobj fh; 165 | netobj oh; 166 | u_int32_t svid; 167 | u_int64_t l_offset; 168 | u_int64_t l_len; 169 | }; 170 | 171 | struct nlm4_share { 172 | string caller_name; 173 | netobj fh; 174 | netobj oh; 175 | fsh_mode mode; 176 | fsh_access access; 177 | }; 178 | 179 | union nlm4_testrply switch (nlm4_stats stat) { 180 | case nlm_denied: 181 | struct nlm4_holder holder; 182 | default: 183 | void; 184 | }; 185 | 186 | struct nlm4_testres { 187 | netobj cookie; 188 | nlm4_testrply stat; 189 | }; 190 | 191 | struct nlm4_testargs { 192 | netobj cookie; 193 | bool exclusive; 194 | struct nlm4_lock alock; 195 | }; 196 | 197 | struct nlm4_res { 198 | netobj cookie; 199 | nlm4_stat stat; 200 | }; 201 | 202 | struct nlm4_lockargs { 203 | netobj cookie; 204 | bool block; 205 | bool exclusive; 206 | struct nlm4_lock alock; 207 | bool reclaim; /* used for recovering locks */ 208 | int state; /* specify local status monitor state */ 209 | }; 210 | 211 | struct nlm4_cancargs { 212 | netobj cookie; 213 | bool block; 214 | bool exclusive; 215 | struct nlm4_lock alock; 216 | }; 217 | 218 | struct nlm4_unlockargs { 219 | netobj cookie; 220 | struct nlm4_lock alock; 221 | }; 222 | 223 | struct nlm4_shareargs { 224 | netobj cookie; 225 | nlm4_share share; 226 | bool reclaim; 227 | }; 228 | 229 | struct nlm4_shareres { 230 | netobj cookie; 231 | nlm4_stats stat; 232 | int sequence; 233 | }; 234 | 235 | /* 236 | * argument for the procedure called by rpc.statd when a monitored host 237 | * status change. 238 | * XXX assumes LM_MAXSTRLEN == SM_MAXSTRLEN 239 | */ 240 | struct nlm_sm_status { 241 | string mon_name; /* name of host */ 242 | int state; /* new state */ 243 | opaque priv[16]; /* private data */ 244 | }; 245 | 246 | /* 247 | * Over-the-wire protocol used between the network lock managers 248 | */ 249 | 250 | program NLM_PROG { 251 | version NLM_SM { 252 | void NLM_SM_NOTIFY(struct nlm_sm_status) = 1; 253 | } = 0; 254 | 255 | version NLM_VERS { 256 | 257 | nlm_testres NLM_TEST(struct nlm_testargs) = 1; 258 | 259 | nlm_res NLM_LOCK(struct nlm_lockargs) = 2; 260 | 261 | nlm_res NLM_CANCEL(struct nlm_cancargs) = 3; 262 | nlm_res NLM_UNLOCK(struct nlm_unlockargs) = 4; 263 | 264 | /* 265 | * remote lock manager call-back to grant lock 266 | */ 267 | nlm_res NLM_GRANTED(struct nlm_testargs)= 5; 268 | /* 269 | * message passing style of requesting lock 270 | */ 271 | void NLM_TEST_MSG(struct nlm_testargs) = 6; 272 | void NLM_LOCK_MSG(struct nlm_lockargs) = 7; 273 | void NLM_CANCEL_MSG(struct nlm_cancargs) =8; 274 | void NLM_UNLOCK_MSG(struct nlm_unlockargs) = 9; 275 | void NLM_GRANTED_MSG(struct nlm_testargs) = 10; 276 | void NLM_TEST_RES(nlm_testres) = 11; 277 | void NLM_LOCK_RES(nlm_res) = 12; 278 | void NLM_CANCEL_RES(nlm_res) = 13; 279 | void NLM_UNLOCK_RES(nlm_res) = 14; 280 | void NLM_GRANTED_RES(nlm_res) = 15; 281 | } = 1; 282 | 283 | version NLM_VERSX { 284 | nlm_shareres NLM_SHARE(nlm_shareargs) = 20; 285 | nlm_shareres NLM_UNSHARE(nlm_shareargs) = 21; 286 | nlm_res NLM_NM_LOCK(nlm_lockargs) = 22; 287 | void NLM_FREE_ALL(nlm_notify) = 23; 288 | } = 3; 289 | 290 | version NLM_VERS4 { 291 | nlm4_testres NLM4_TEST(nlm4_testargs) = 1; 292 | nlm4_res NLM4_LOCK(nlm4_lockargs) = 2; 293 | nlm4_res NLM4_CANCEL(nlm4_cancargs) = 3; 294 | nlm4_res NLM4_UNLOCK(nlm4_unlockargs) = 4; 295 | nlm4_res NLM4_GRANTED(nlm4_testargs) = 5; 296 | void NLM4_TEST_MSG(nlm4_testargs) = 6; 297 | void NLM4_LOCK_MSG(nlm4_lockargs) = 7; 298 | void NLM4_CANCEL_MSG(nlm4_cancargs) = 8; 299 | void NLM4_UNLOCK_MSG(nlm4_unlockargs) = 9; 300 | void NLM4_GRANTED_MSG(nlm4_testargs) = 10; 301 | void NLM4_TEST_RES(nlm4_testres) = 11; 302 | void NLM4_LOCK_RES(nlm4_res) = 12; 303 | void NLM4_CANCEL_RES(nlm4_res) = 13; 304 | void NLM4_UNLOCK_RES(nlm4_res) = 14; 305 | void NLM4_GRANTED_RES(nlm4_res) = 15; 306 | nlm4_shareres NLM4_SHARE(nlm4_shareargs) = 20; 307 | nlm4_shareres NLM4_UNSHARE(nlm4_shareargs) = 21; 308 | nlm4_res NLM4_NM_LOCK(nlm4_lockargs) = 22; 309 | void NLM4_FREE_ALL(nlm_notify) = 23; 310 | } = 4; 311 | } = 100021; 312 | -------------------------------------------------------------------------------- /nsm.x: -------------------------------------------------------------------------------- 1 | /* $Id: nsm.x,v 1.2 2006/05/11 21:58:59 dancy Exp $ */ 2 | 3 | /* 4 | * This defines the maximum length of the string 5 | * identifying the caller. 6 | */ 7 | const SM_MAXSTRLEN = 1024; 8 | 9 | struct sm_name { 10 | string mon_name; 11 | }; 12 | 13 | enum res { 14 | STAT_SUCC = 0, /* NSM agrees to monitor. */ 15 | STAT_FAIL = 1 /* NSM cannot monitor. */ 16 | }; 17 | 18 | struct sm_stat_res { 19 | res res_stat; 20 | int state; 21 | }; 22 | 23 | struct sm_stat { 24 | int state; /* state number of NSM */ 25 | }; 26 | 27 | struct my_id { 28 | string my_name; /* hostname */ 29 | int my_prog; /* RPC program number */ 30 | int my_vers; /* program version number */ 31 | int my_proc; /* procedure number */ 32 | }; 33 | 34 | struct mon_id { 35 | string mon_name; /* name of the host to be monitored */ 36 | struct my_id my_id; 37 | }; 38 | 39 | struct mon { 40 | struct mon_id mon_id; 41 | opaque priv[16]; /* private information */ 42 | }; 43 | 44 | struct stat_chge { 45 | string mon_name; 46 | int state; 47 | }; 48 | 49 | struct nsm_callback_status { 50 | string mon_name; 51 | int state; 52 | opaque priv[16]; /* for private information */ 53 | }; 54 | 55 | /* 56 | * Protocol description for the NSM program. 57 | */ 58 | 59 | program SM_PROG { 60 | version SM_VERS { 61 | void SM_NULL(void) = 0; 62 | struct sm_stat_res SM_STAT(struct sm_name) = 1; 63 | struct sm_stat_res SM_MON(struct mon) = 2; 64 | struct sm_stat SM_UNMON(struct mon_id) = 3; 65 | struct sm_stat SM_UNMON_ALL(struct my_id) = 4; 66 | void SM_SIMU_CRASH(void) = 5; 67 | void SM_NOTIFY(struct stat_chge) = 6; 68 | } = 1; 69 | } = 100024; 70 | 71 | -------------------------------------------------------------------------------- /openfile.cl: -------------------------------------------------------------------------------- 1 | (in-package :user) 2 | 3 | ;; keys are file handles. 4 | (defparameter *open-file-cache* (make-hash-table :test #'eq)) 5 | (defparameter *open-file-cache-lock* (mp:make-process-lock)) 6 | 7 | (defstruct openfile 8 | (lock (mp:make-process-lock)) 9 | direction 10 | stream 11 | (lastaccess (excl::cl-internal-real-time)) 12 | (refcount 0)) 13 | 14 | 15 | ;; Call with *open-file-cache-lock* held 16 | (defmacro locate-open-file (fh) 17 | `(gethash ,fh *open-file-cache*)) 18 | 19 | ;; Call with *open-file-cache-lock* held 20 | (defmacro put-open-file (fh of) 21 | `(setf (gethash ,fh *open-file-cache*) ,of)) 22 | 23 | ;; Only called via the with-nfs-open-file macro. 24 | (defun get-open-file (fh direction) 25 | (declare (optimize (speed 3) (safety 0) (debug 0))) 26 | (mp:with-process-lock (*open-file-cache-lock*) 27 | (let ((of (locate-open-file fh))) 28 | (when (null of) 29 | ;; no entry found.. make a new one. 30 | (setf of (make-openfile :direction direction)) 31 | (setf (openfile-stream of) 32 | (if* (eq direction :input) 33 | then (unicode-open (fh-pathname fh) :direction :input) 34 | else (unicode-open (fh-pathname fh) :direction :io 35 | :if-exists :open 36 | :if-does-not-exist :create))) 37 | #+ignore 38 | (format t "Opened for ~a ~a~%" direction (fh-pathname fh)) 39 | (put-open-file fh of)) 40 | ;; common 41 | 42 | (if* (and (not (eq direction (openfile-direction of))) 43 | (eq direction :output)) 44 | then ;; Escalate from read-only to read-write for open type, 45 | ;; because we don't want to open read-write unless we have 46 | ;; to. 47 | #+ignore 48 | (progn 49 | (format t "Escalating open type for ~a~%" (fh-pathname fh)) 50 | (format t "Closing...~%")) 51 | (close (openfile-stream of)) 52 | ;; Remove from hash in case the the reopen fails. 53 | (remhash fh *open-file-cache*) 54 | #+ignore (format t "Reopening for output...~%") 55 | ;; This could possibly result in an error. 56 | (setf (openfile-stream of) 57 | (unicode-open (fh-pathname fh) :direction :io 58 | :if-exists :open 59 | :if-does-not-exist :create)) 60 | (put-open-file fh of) 61 | #+ignore (format t "Escalation complete.~%")) 62 | 63 | (setf (openfile-lastaccess of) (excl::cl-internal-real-time)) 64 | (values (openfile-stream of) of)))) 65 | 66 | (defmacro with-nfs-open-file ((var fh direction &key (of (gensym))) 67 | &body body) 68 | (let* ((g-fh (gensym)) 69 | (g-direction (gensym))) 70 | `(let* ((,g-fh ,fh) 71 | (,g-direction ,direction)) 72 | (multiple-value-bind (,var ,of) 73 | (get-open-file ,g-fh ,g-direction) 74 | (declare (ignore-if-unused ,var)) 75 | (mp:with-process-lock ((openfile-lock ,of)) 76 | (incf (the fixnum (openfile-refcount ,of))) 77 | (unwind-protect (progn ,@body) 78 | (decf (the fixnum (openfile-refcount ,of))) 79 | (when (and (= 0 (the fixnum (openfile-refcount ,of))) 80 | (= 0 *open-file-reap-time*)) 81 | (mp:with-process-lock (*open-file-cache-lock*) 82 | (reap-open-file ,g-fh ,of))))))))) 83 | 84 | ;; Called by: 85 | ;; nfsd-rename, :operator 86 | ;; nfsd-remove, :operator 87 | (defun close-open-file (fh &key check-refcount) 88 | (mp:with-process-lock (*open-file-cache-lock*) 89 | (let ((of (locate-open-file fh))) 90 | (when of 91 | (if (and check-refcount (not (zerop (openfile-refcount of)))) 92 | (return-from close-open-file :still-open)) 93 | (reap-open-file fh of))))) 94 | 95 | ;; NOTE: callers are responsible for calling this function only when 96 | ;; they hold the *open-file-cache-lock* lock. 97 | (defun reap-open-file (fh of) 98 | (when (not (zerop (openfile-refcount of))) 99 | (error "reap-open-file called when refcount is non-zero")) 100 | #+ignore (format t "Closing ~a~%" (fh-pathname fh)) 101 | (close (openfile-stream of)) 102 | (remhash fh *open-file-cache*)) 103 | 104 | 105 | (defun reap-open-files () 106 | (mp:with-process-lock (*open-file-cache-lock*) 107 | (let ((now (excl::cl-internal-real-time)) 108 | (reaptime *open-file-reap-time*)) 109 | (maphash 110 | #'(lambda (fh of) 111 | (when (and (>= now (+ reaptime (openfile-lastaccess of))) 112 | (zerop (openfile-refcount of))) 113 | (reap-open-file fh of))) 114 | *open-file-cache*)))) 115 | 116 | (defun initialize-reaper-process () 117 | (mp:process-run-function "open file reaper" #'nfsd-open-file-reaper)) 118 | 119 | (defun nfsd-open-file-reaper () 120 | (loop 121 | (if* (= 0 *open-file-reap-time*) 122 | then ;; The idea is, that if *open-file-reap-time* is 0, the only 123 | ;; way we can do real work in this loop is if the configuration 124 | ;; program changes the value, and checking it once a minute 125 | ;; seems reasonable, in this case. 126 | (sleep 60) 127 | else (sleep (max *open-file-reap-time* 1)) 128 | (reap-open-files)))) 129 | -------------------------------------------------------------------------------- /portmap.x: -------------------------------------------------------------------------------- 1 | /* $Id: portmap.x,v 1.2 2008/01/02 23:19:27 dancy Exp $ */ 2 | 3 | /* Extracted from rfc1057.txt and tweaked some */ 4 | 5 | const PMAP_PORT = 111; /* portmapper port number */ 6 | 7 | struct mapping { 8 | unsigned int prog; 9 | unsigned int vers; 10 | unsigned int prot; 11 | unsigned int port; 12 | }; 13 | 14 | 15 | const IPPROTO_TCP = 6; /* protocol number for TCP/IP */ 16 | const IPPROTO_UDP = 17; /* protocol number for UDP/IP */ 17 | 18 | typedef struct pmapentry *pmaplist; 19 | struct pmapentry { 20 | mapping map; 21 | pmaplist next; 22 | }; 23 | 24 | struct call_args { 25 | unsigned int prog; 26 | unsigned int vers; 27 | unsigned int proc; 28 | opaque args<>; 29 | }; 30 | 31 | 32 | struct call_result { 33 | unsigned int port; 34 | opaque res<>; 35 | }; 36 | 37 | /* 38 | * A mapping of (program, version, network ID) to address 39 | * 40 | * The network identifier (r_netid): 41 | * This is a string that represents a local identification for a 42 | * network. This is defined by a system administrator based on local 43 | * conventions, and cannot be depended on to have the same value on 44 | * every system. 45 | */ 46 | struct rpcb { 47 | unsigned long r_prog; /* program number */ 48 | unsigned long r_vers; /* version number */ 49 | string r_netid<>; /* network id */ 50 | string r_addr<>; /* universal address */ 51 | string r_owner<>; /* owner of this service */ 52 | }; 53 | 54 | struct rp__list { 55 | rpcb rpcb_map; 56 | struct rp__list *rpcb_next; 57 | }; 58 | 59 | 60 | typedef rp__list *rpcblist_ptr; /* results of RPCBPROC_DUMP */ 61 | 62 | 63 | /* 64 | * Arguments of remote calls 65 | */ 66 | struct rpcb_rmtcallargs { 67 | unsigned long prog; /* program number */ 68 | unsigned long vers; /* version number */ 69 | unsigned long proc; /* procedure number */ 70 | opaque args<>; /* argument */ 71 | }; 72 | 73 | 74 | /* 75 | * Results of the remote call 76 | */ 77 | struct rpcb_rmtcallres { 78 | string addr<>; /* remote universal address */ 79 | opaque results<>; /* result */ 80 | }; 81 | 82 | 83 | /* 84 | * rpcb_entry contains a merged address of a service on a particular 85 | * transport, plus associated netconfig information. A list of 86 | * rpcb_entry items is returned by RPCBPROC_GETADDRLIST. The meanings 87 | * and values used for the r_nc_* fields are given below. 88 | * 89 | * The network identifier (r_nc_netid): 90 | 91 | * This is a string that represents a local identification for a 92 | * network. This is defined by a system administrator based on 93 | * local conventions, and cannot be depended on to have the same 94 | * value on every system. 95 | * 96 | * Transport semantics (r_nc_semantics): 97 | * This represents the type of transport, and has the following values: 98 | * NC_TPI_CLTS (1) Connectionless 99 | * NC_TPI_COTS (2) Connection oriented 100 | * NC_TPI_COTS_ORD (3) Connection oriented with graceful close 101 | * NC_TPI_RAW (4) Raw transport 102 | * 103 | * Protocol family (r_nc_protofmly): 104 | * This identifies the family to which the protocol belongs. The 105 | * following values are defined: 106 | * NC_NOPROTOFMLY "-" 107 | * NC_LOOPBACK "loopback" 108 | * NC_INET "inet" 109 | * NC_IMPLINK "implink" 110 | * NC_PUP "pup" 111 | * NC_CHAOS "chaos" 112 | * NC_NS "ns" 113 | * NC_NBS "nbs" 114 | * NC_ECMA "ecma" 115 | * NC_DATAKIT "datakit" 116 | * NC_CCITT "ccitt" 117 | * NC_SNA "sna" 118 | * NC_DECNET "decnet" 119 | * NC_DLI "dli" 120 | * NC_LAT "lat" 121 | * NC_HYLINK "hylink" 122 | * NC_APPLETALK "appletalk" 123 | * NC_NIT "nit" 124 | * NC_IEEE802 "ieee802" 125 | * NC_OSI "osi" 126 | * NC_X25 "x25" 127 | * NC_OSINET "osinet" 128 | * NC_GOSIP "gosip" 129 | * 130 | * Protocol name (r_nc_proto): 131 | * This identifies a protocol within a family. The following are 132 | * currently defined: 133 | * NC_NOPROTO "-" 134 | * NC_TCP "tcp" 135 | * NC_UDP "udp" 136 | * NC_ICMP "icmp" 137 | */ 138 | struct rpcb_entry { 139 | string r_maddr<>; /* merged address of service */ 140 | string r_nc_netid<>; /* netid field */ 141 | unsigned long r_nc_semantics; /* semantics of transport */ 142 | string r_nc_protofmly<>; /* protocol family */ 143 | string r_nc_proto<>; /* protocol name */ 144 | }; 145 | 146 | /* 147 | * A list of addresses supported by a service. 148 | */ 149 | struct rpcb_entry_list { 150 | rpcb_entry rpcb_entry_map; 151 | struct rpcb_entry_list *rpcb_entry_next; 152 | }; 153 | 154 | typedef rpcb_entry_list *rpcb_entry_list_ptr; 155 | 156 | /* 157 | * rpcbind statistics 158 | */ 159 | 160 | /* Never referenced -- dancy 161 | const rpcb_highproc_2 = RPCBPROC_CALLIT; 162 | const rpcb_highproc_3 = RPCBPROC_TADDR2UADDR; 163 | const rpcb_highproc_4 = RPCBPROC_GETSTAT; 164 | */ 165 | 166 | const RPCBSTAT_HIGHPROC = 13; /* # of procs in rpcbind V4 plus one */ 167 | const RPCBVERS_STAT = 3; /* provide only for rpcbind V2, V3 and V4 */ 168 | const RPCBVERS_4_STAT = 2; 169 | const RPCBVERS_3_STAT = 1; 170 | const RPCBVERS_2_STAT = 0; 171 | 172 | /* Link list of all the stats about getport and getaddr */ 173 | struct rpcbs_addrlist { 174 | unsigned long prog; 175 | unsigned long vers; 176 | int success; 177 | int failure; 178 | string netid<>; 179 | struct rpcbs_addrlist *next; 180 | }; 181 | 182 | /* Link list of all the stats about rmtcall */ 183 | struct rpcbs_rmtcalllist { 184 | unsigned long prog; 185 | unsigned long vers; 186 | unsigned long proc; 187 | int success; 188 | int failure; 189 | int indirect; /* whether callit or indirect */ 190 | string netid<>; 191 | struct rpcbs_rmtcalllist *next; 192 | }; 193 | 194 | typedef int rpcbs_proc[RPCBSTAT_HIGHPROC]; 195 | typedef rpcbs_addrlist *rpcbs_addrlist_ptr; 196 | typedef rpcbs_rmtcalllist *rpcbs_rmtcalllist_ptr; 197 | 198 | struct rpcb_stat { 199 | rpcbs_proc info; 200 | int setinfo; 201 | int unsetinfo; 202 | rpcbs_addrlist_ptr addrinfo; 203 | rpcbs_rmtcalllist_ptr rmtinfo; 204 | }; 205 | 206 | /* 207 | * One rpcb_stat structure is returned for each version of rpcbind 208 | * being monitored. 209 | */ 210 | 211 | typedef rpcb_stat rpcb_stat_byvers[RPCBVERS_STAT]; 212 | 213 | /* 214 | * netbuf structure, used to store the transport specific form of 215 | * a universal transport address. 216 | */ 217 | struct netbuf { 218 | unsigned int maxlen; 219 | opaque buf<>; 220 | }; 221 | 222 | 223 | program PMAP_PROG { 224 | version PMAP_VERS { 225 | void 226 | PMAPPROC_NULL(void) = 0; 227 | 228 | bool 229 | PMAPPROC_SET(mapping) = 1; 230 | 231 | bool 232 | PMAPPROC_UNSET(mapping) = 2; 233 | 234 | unsigned int 235 | PMAPPROC_GETPORT(mapping) = 3; 236 | 237 | pmaplist 238 | PMAPPROC_DUMP(void) = 4; 239 | 240 | call_result 241 | PMAPPROC_CALLIT(call_args) = 5; 242 | } = 2; 243 | version RPCBVERS { 244 | void RPCBPROC_NULL(rpcb) = 0; /* Added by dancy */ 245 | 246 | bool 247 | RPCBPROC_SET(rpcb) = 1; 248 | 249 | bool 250 | RPCBPROC_UNSET(rpcb) = 2; 251 | 252 | string 253 | RPCBPROC_GETADDR(rpcb) = 3; 254 | 255 | rpcblist_ptr 256 | RPCBPROC_DUMP(void) = 4; 257 | 258 | rpcb_rmtcallres 259 | RPCBPROC_CALLIT(rpcb_rmtcallargs) = 5; 260 | 261 | unsigned int 262 | RPCBPROC_GETTIME(void) = 6; 263 | 264 | netbuf 265 | RPCBPROC_UADDR2TADDR(string) = 7; 266 | 267 | string 268 | RPCBPROC_TADDR2UADDR(netbuf) = 8; 269 | } = 3; 270 | 271 | version RPCBVERS4 { 272 | void RPCBPROC_NULL(rpcb) = 0; /* Added by dancy */ 273 | 274 | bool 275 | RPCBPROC_SET(rpcb) = 1; 276 | 277 | bool 278 | RPCBPROC_UNSET(rpcb) = 2; 279 | 280 | string 281 | RPCBPROC_GETADDR(rpcb) = 3; 282 | 283 | rpcblist_ptr 284 | RPCBPROC_DUMP(void) = 4; 285 | 286 | /* 287 | * NOTE: RPCBPROC_BCAST has the same functionality as CALLIT; 288 | * the new name is intended to indicate that this 289 | * procedure should be used for broadcast RPC, and 290 | * RPCBPROC_INDIRECT should be used for indirect calls. 291 | */ 292 | rpcb_rmtcallres 293 | RPCBPROC_BCAST(rpcb_rmtcallargs) = /*RPCBPROC_CALLIT*/ 5; 294 | 295 | unsigned int 296 | 297 | RPCBPROC_GETTIME(void) = 6; 298 | 299 | netbuf 300 | RPCBPROC_UADDR2TADDR(string) = 7; 301 | 302 | string 303 | RPCBPROC_TADDR2UADDR(netbuf) = 8; 304 | 305 | string 306 | RPCBPROC_GETVERSADDR(rpcb) = 9; 307 | 308 | rpcb_rmtcallres 309 | RPCBPROC_INDIRECT(rpcb_rmtcallargs) = 10; 310 | 311 | rpcb_entry_list_ptr 312 | RPCBPROC_GETADDRLIST(rpcb) = 11; 313 | 314 | rpcb_stat_byvers 315 | RPCBPROC_GETSTAT(void) = 12; 316 | } = 4; 317 | 318 | } = 100000; 319 | -------------------------------------------------------------------------------- /servicelib.nsh: -------------------------------------------------------------------------------- 1 | ;; $Id: servicelib.nsh,v 1.1 2006/06/22 23:39:49 dancy Exp $ 2 | 3 | ;------------------------------------------------------------------------------ 4 | ;-- obtained from: 5 | ;-- http://nsis.sourceforge.net/archive/viewpage.php?pageid=345 6 | 7 | 8 | ; NSIS SERVICE LIBRARY - servicelib.nsh 9 | ; Version 1.3 - January 5th, 2006 10 | ; Questions/Comments - dselkirk@hotmail.com 11 | ; 12 | ; Description: 13 | ; Provides an interface to window services 14 | ; 15 | ; Inputs: 16 | ; action - systemlib action ie. create, delete, start, stop, pause, 17 | ; continue, installed, running, status 18 | ; name - name of service to manipulate 19 | ; param - action parameters; usage: var1=value1;var2=value2;...etc. 20 | ; (don't forget to add a ';' after the last value!) 21 | ; 22 | ; Actions: 23 | ; create - creates a new windows service 24 | ; Parameters: 25 | ; path - path to service executable 26 | ; autostart - automatically start with system ie. 1|0 27 | ; interact - interact with the desktop ie. 1|0 28 | ; machine - machine name where to install service 29 | ; user - user that runs the service 30 | ; password - password of the above user 31 | ; 32 | ; delete - deletes a windows service 33 | ; start - start a stopped windows service 34 | ; stop - stops a running windows service 35 | ; pause - pauses a running windows service 36 | ; continue - continues a paused windows service 37 | ; installed - is the provided service installed 38 | ; Parameters: 39 | ; action - if true then invokes the specified action 40 | ; running - is the provided service running 41 | ; Parameters: 42 | ; action - if true then invokes the specified action 43 | ; status - check the status of the provided service 44 | ; 45 | ; If run from uninstall define "UN" as "un." gefore running. 46 | ; 47 | ; Usage: 48 | ; Method 1: 49 | ; Push "action" 50 | ; Push "name" 51 | ; Push "param" 52 | ; Call Service 53 | ; Pop $0 ;response 54 | ; 55 | ; Method 2: 56 | ; !insertmacro SERVICE "action" "name" "param" 57 | ; 58 | ; History: 59 | ; 1.0 - 09/15/2003 - Initial release 60 | ; 1.1 - 09/16/2003 - Changed &l to i, thx brainsucker 61 | ; 1.2 - 02/29/2004 - Fixed documentation. 62 | 63 | !ifndef SERVICELIB 64 | !define SERVICELIB 65 | 66 | !define SC_MANAGER_ALL_ACCESS 0x3F 67 | !define SERVICE_ALL_ACCESS 0xF01FF 68 | 69 | !define SERVICE_CONTROL_STOP 1 70 | !define SERVICE_CONTROL_PAUSE 2 71 | !define SERVICE_CONTROL_CONTINUE 3 72 | 73 | !define SERVICE_STOPPED 0x1 74 | !define SERVICE_START_PENDING 0x2 75 | !define SERVICE_STOP_PENDING 0x3 76 | !define SERVICE_RUNNING 0x4 77 | !define SERVICE_CONTINUE_PENDING 0x5 78 | !define SERVICE_PAUSE_PENDING 0x6 79 | !define SERVICE_PAUSED 0x7 80 | 81 | !ifndef UN 82 | !define UN "" 83 | !endif 84 | 85 | !macro SERVICE ACTION NAME PARAM 86 | Push '${ACTION}' 87 | Push '${NAME}' 88 | Push '${PARAM}' 89 | Call ${UN}Service 90 | !macroend 91 | 92 | !macro FUNC_GETPARAM 93 | Push $0 94 | Push $1 95 | Push $2 96 | Push $3 97 | Push $4 98 | Push $5 99 | Push $6 100 | Push $7 101 | Exch 8 102 | Pop $1 ;name 103 | Exch 8 104 | Pop $2 ;source 105 | StrCpy $0 "" 106 | StrLen $7 $2 107 | StrCpy $3 0 108 | lbl_loop: 109 | IntCmp $3 $7 0 0 lbl_done 110 | StrLen $4 "$1=" 111 | StrCpy $5 $2 $4 $3 112 | StrCmp $5 "$1=" 0 lbl_next 113 | IntOp $5 $3 + $4 114 | StrCpy $3 $5 115 | lbl_loop2: 116 | IntCmp $3 $7 0 0 lbl_done 117 | StrCpy $6 $2 1 $3 118 | StrCmp $6 ";" 0 lbl_next2 119 | IntOp $6 $3 - $5 120 | StrCpy $0 $2 $6 $5 121 | Goto lbl_done 122 | lbl_next2: 123 | IntOp $3 $3 + 1 124 | Goto lbl_loop2 125 | lbl_next: 126 | IntOp $3 $3 + 1 127 | Goto lbl_loop 128 | lbl_done: 129 | Pop $5 130 | Pop $4 131 | Pop $3 132 | Pop $2 133 | Pop $1 134 | Exch 2 135 | Pop $6 136 | Pop $7 137 | Exch $0 138 | !macroend 139 | 140 | !macro CALL_GETPARAM VAR NAME DEFAULT LABEL 141 | Push $1 142 | Push ${NAME} 143 | Call ${UN}GETPARAM 144 | Pop $6 145 | StrCpy ${VAR} "${DEFAULT}" 146 | StrCmp $6 "" "${LABEL}" 0 147 | StrCpy ${VAR} $6 148 | !macroend 149 | 150 | !macro FUNC_SERVICE UN 151 | Push $0 152 | Push $1 153 | Push $2 154 | Push $3 155 | Push $4 156 | Push $5 157 | Push $6 158 | Push $7 159 | Exch 8 160 | Pop $1 ;param 161 | Exch 8 162 | Pop $2 ;name 163 | Exch 8 164 | Pop $3 ;action 165 | ;$0 return 166 | ;$4 OpenSCManager 167 | ;$5 OpenService 168 | 169 | 170 | StrCpy $0 "false" 171 | System::Call 'advapi32::OpenSCManagerA(n, n, i ${SC_MANAGER_ALL_ACCESS}) i.r4' 172 | IntCmp $4 0 lbl_done 173 | StrCmp $3 "create" lbl_create 174 | System::Call 'advapi32::OpenServiceA(i r4, t r2, i ${SERVICE_ALL_ACCESS}) i.r5' 175 | IntCmp $5 0 lbl_done 176 | 177 | lbl_select: 178 | StrCmp $3 "delete" lbl_delete 179 | StrCmp $3 "start" lbl_start 180 | StrCmp $3 "stop" lbl_stop 181 | StrCmp $3 "pause" lbl_pause 182 | StrCmp $3 "continue" lbl_continue 183 | StrCmp $3 "installed" lbl_installed 184 | StrCmp $3 "running" lbl_running 185 | StrCmp $3 "status" lbl_status 186 | Goto lbl_done 187 | 188 | ; create service 189 | lbl_create: 190 | Push $R1 ;machine 191 | Push $R2 ;user 192 | Push $R3 ;password 193 | Push $R4 ;interact 194 | Push $R5 ;autostart 195 | Push $R6 ;path 196 | 197 | !insertmacro CALL_GETPARAM $R1 "machine" "n" "lbl_machine" 198 | lbl_machine: 199 | 200 | !insertmacro CALL_GETPARAM $R2 "user" "n" "lbl_user" 201 | lbl_user: 202 | 203 | !insertmacro CALL_GETPARAM $R3 "password" "n" "lbl_password" 204 | lbl_password: 205 | 206 | !insertmacro CALL_GETPARAM $R4 "interact" "0x10" "lbl_interact" 207 | StrCpy $6 0x10 208 | IntCmp $R4 0 +2 209 | IntOp $6 $6 | 0x100 210 | StrCpy $R4 $6 211 | lbl_interact: 212 | 213 | !insertmacro CALL_GETPARAM $R5 "autostart" "0x3" "lbl_autostart" 214 | StrCpy $6 0x3 215 | IntCmp $R5 0 +2 216 | StrCpy $6 0x2 217 | StrCpy $R5 $6 218 | lbl_autostart: 219 | 220 | !insertmacro CALL_GETPARAM $R6 "path" "n" "lbl_path" 221 | lbl_path: 222 | 223 | System::Call 'advapi32::CreateServiceA(i r4, t r2, t r2, i ${SERVICE_ALL_ACCESS}, \ 224 | i R4, i R5, i 0, t R6, n, n, R1, R2, R3) i.r6' 225 | Pop $R6 226 | Pop $R5 227 | Pop $R4 228 | Pop $R3 229 | Pop $R2 230 | Pop $R1 231 | StrCmp $6 0 lbl_done lbl_good 232 | 233 | ; delete service 234 | lbl_delete: 235 | System::Call 'advapi32::DeleteService(i r5) i.r6' 236 | StrCmp $6 0 lbl_done lbl_good 237 | 238 | ; start service 239 | lbl_start: 240 | System::Call 'advapi32::StartServiceA(i r5, i 0, i 0) i.r6' 241 | StrCmp $6 0 lbl_done lbl_good 242 | 243 | ; stop service 244 | lbl_stop: 245 | Push $R1 246 | System::Call '*(i,i,i,i,i,i,i) i.R1' 247 | System::Call 'advapi32::ControlService(i r5, i ${SERVICE_CONTROL_STOP}, i $R1) i' 248 | System::Free $R1 249 | Pop $R1 250 | StrCmp $6 0 lbl_done lbl_good 251 | 252 | ; pause service 253 | lbl_pause: 254 | Push $R1 255 | System::Call '*(i,i,i,i,i,i,i) i.R1' 256 | System::Call 'advapi32::ControlService(i r5, i ${SERVICE_CONTROL_PAUSE}, i $R1) i' 257 | System::Free $R1 258 | Pop $R1 259 | StrCmp $6 0 lbl_done lbl_good 260 | 261 | ; continue service 262 | lbl_continue: 263 | Push $R1 264 | System::Call '*(i,i,i,i,i,i,i) i.R1' 265 | System::Call 'advapi32::ControlService(i r5, i ${SERVICE_CONTROL_CONTINUE}, i $R1) i' 266 | System::Free $R1 267 | Pop $R1 268 | StrCmp $6 0 lbl_done lbl_good 269 | 270 | ; is installed 271 | lbl_installed: 272 | !insertmacro CALL_GETPARAM $7 "action" "" "lbl_good" 273 | StrCpy $3 $7 274 | Goto lbl_select 275 | 276 | ; is service running 277 | lbl_running: 278 | Push $R1 279 | System::Call '*(i,i,i,i,i,i,i) i.R1' 280 | System::Call 'advapi32::QueryServiceStatus(i r5, i $R1) i' 281 | System::Call '*$R1(i, i.r6)' 282 | System::Free $R1 283 | Pop $R1 284 | IntFmt $6 "0x%X" $6 285 | StrCmp $6 ${SERVICE_RUNNING} 0 lbl_done 286 | !insertmacro CALL_GETPARAM $7 "action" "" "lbl_good" 287 | StrCpy $3 $7 288 | Goto lbl_select 289 | 290 | lbl_status: 291 | Push $R1 292 | System::Call '*(i,i,i,i,i,i,i) i.R1' 293 | System::Call 'advapi32::QueryServiceStatus(i r5, i $R1) i' 294 | System::Call '*$R1(i, i .r6)' 295 | System::Free $R1 296 | Pop $R1 297 | IntFmt $6 "0x%X" $6 298 | StrCpy $0 "running" 299 | IntCmp $6 ${SERVICE_RUNNING} lbl_done 300 | StrCpy $0 "stopped" 301 | IntCmp $6 ${SERVICE_STOPPED} lbl_done 302 | StrCpy $0 "start_pending" 303 | IntCmp $6 ${SERVICE_START_PENDING} lbl_done 304 | StrCpy $0 "stop_pending" 305 | IntCmp $6 ${SERVICE_STOP_PENDING} lbl_done 306 | StrCpy $0 "running" 307 | IntCmp $6 ${SERVICE_RUNNING} lbl_done 308 | StrCpy $0 "continue_pending" 309 | IntCmp $6 ${SERVICE_CONTINUE_PENDING} lbl_done 310 | StrCpy $0 "pause_pending" 311 | IntCmp $6 ${SERVICE_PAUSE_PENDING} lbl_done 312 | StrCpy $0 "paused" 313 | IntCmp $6 ${SERVICE_PAUSED} lbl_done 314 | StrCpy $0 "unknown" 315 | 316 | lbl_good: 317 | StrCpy $0 "true" 318 | lbl_done: 319 | IntCmp $5 0 +2 320 | System::Call 'advapi32::CloseServiceHandle(i r5) n' 321 | IntCmp $4 0 +2 322 | System::Call 'advapi32::CloseServiceHandle(i r4) n' 323 | Pop $4 324 | Pop $3 325 | Pop $2 326 | Pop $1 327 | Exch 3 328 | Pop $5 329 | Pop $7 330 | Pop $6 331 | Exch $0 332 | !macroend 333 | 334 | Function Service 335 | !insertmacro FUNC_SERVICE "" 336 | FunctionEnd 337 | 338 | Function un.Service 339 | !insertmacro FUNC_SERVICE "un." 340 | FunctionEnd 341 | 342 | Function GetParam 343 | !insertmacro FUNC_GETPARAM 344 | FunctionEnd 345 | 346 | Function un.GetParam 347 | !insertmacro FUNC_GETPARAM 348 | FunctionEnd 349 | 350 | !endif 351 | -------------------------------------------------------------------------------- /sunrpc.x: -------------------------------------------------------------------------------- 1 | /* Extracted from rfc1057 (plus some tweaks) */ 2 | /* Updated to rfc1831 */ 3 | 4 | const TRUE = 1; 5 | const FALSE = 0; 6 | 7 | enum auth_flavor { 8 | AUTH_NULL = 0, 9 | AUTH_UNIX = 1, 10 | AUTH_SHORT = 2, 11 | AUTH_DES = 3 12 | /* and more to be defined */ 13 | }; 14 | 15 | struct opaque_auth { 16 | auth_flavor flavor; 17 | opaque body<400>; 18 | }; 19 | 20 | enum msg_type { 21 | CALL = 0, 22 | REPLY = 1 23 | }; 24 | 25 | enum reply_stat { 26 | MSG_ACCEPTED = 0, 27 | MSG_DENIED = 1 28 | }; 29 | 30 | enum accept_stat { 31 | SUCCESS = 0, /* RPC executed successfully */ 32 | PROG_UNAVAIL = 1, /* remote hasn't exported program */ 33 | PROG_MISMATCH = 2, /* remote can't support version # */ 34 | PROC_UNAVAIL = 3, /* program can't support procedure */ 35 | GARBAGE_ARGS = 4, /* procedure can't decode params */ 36 | SYSTEM_ERR = 5 /* errors like memory allocation failure */ 37 | }; 38 | 39 | enum reject_stat { 40 | RPC_MISMATCH = 0, /* RPC version number != 2 */ 41 | AUTH_ERROR = 1 /* remote can't authenticate caller */ 42 | }; 43 | 44 | enum auth_stat { 45 | AUTH_OK = 0, /* success */ 46 | /* 47 | * failed at remote end 48 | */ 49 | AUTH_BADCRED = 1, /* bad credentials (seal broken) */ 50 | AUTH_REJECTEDCRED = 2, /* client must begin new session */ 51 | AUTH_BADVERF = 3, /* bad verifier (seal broken) */ 52 | AUTH_REJECTEDVERF = 4, /* verifier expired or replayed */ 53 | AUTH_TOOWEAK = 5, /* rejected for security reasons */ 54 | /* 55 | * failed locally 56 | */ 57 | AUTH_INVALIDRESP = 6, /* bogus response verifier */ 58 | AUTH_FAILED = 7 /* reason unknown */ 59 | }; 60 | 61 | struct rpc_msg { 62 | unsigned int xid; 63 | union switch (msg_type mtype) { 64 | case CALL: 65 | call_body cbody; 66 | case REPLY: 67 | reply_body rbody; 68 | } body; 69 | }; 70 | 71 | struct call_body { 72 | unsigned int rpcvers; /* must be equal to two (2) */ 73 | unsigned int prog; 74 | unsigned int vers; 75 | unsigned int proc; 76 | opaque_auth cred; 77 | opaque_auth verf; 78 | /* procedure specific parameters start here */ 79 | }; 80 | 81 | union reply_body switch (reply_stat stat) { 82 | case MSG_ACCEPTED: 83 | accepted_reply areply; 84 | case MSG_DENIED: 85 | rejected_reply rreply; 86 | }; 87 | 88 | struct accepted_reply { 89 | opaque_auth verf; 90 | union switch (accept_stat stat) { 91 | case SUCCESS: 92 | /* opaque results[0]; */ 93 | xdr results; 94 | /* 95 | * procedure-specific results start here 96 | */ 97 | case PROG_MISMATCH: 98 | struct { 99 | unsigned int low; 100 | unsigned int high; 101 | } mismatch_info; 102 | default: 103 | /* 104 | * Void. Cases include PROG_UNAVAIL, PROC_UNAVAIL, 105 | * GARBAGE_ARGS, and SYSTEM_ERR. 106 | */ 107 | void; 108 | } reply_data; 109 | }; 110 | 111 | union rejected_reply switch (reject_stat status) { 112 | case RPC_MISMATCH: 113 | struct { 114 | unsigned int low; 115 | unsigned int high; 116 | } mismatch_info; 117 | case AUTH_ERROR: 118 | auth_stat stat; 119 | }; 120 | 121 | struct auth_unix { 122 | unsigned int stamp; 123 | string machinename<255>; 124 | unsigned int uid; 125 | unsigned int gid; 126 | unsigned int gids<16>; 127 | }; 128 | 129 | -------------------------------------------------------------------------------- /telnet.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; 3 | ;; This source code is in the public domain. 4 | 5 | (in-package :user) 6 | 7 | (defun start-telnet-server (&key (port 1234)) 8 | (mp:process-run-function "telnet server" 'start-telnet-server-1 port)) 9 | 10 | (defun start-telnet-server-1 (port) 11 | (loop 12 | (let ((socket (socket:make-socket :connect :passive :local-port port 13 | :reuse-address t))) 14 | (unwind-protect 15 | (loop 16 | (let ((connection 17 | (ignore-errors (socket:accept-connection socket))) 18 | ;; The ignore-errors protects against the rare 19 | ;; occurrence of accept-connection signaling 20 | ;; an error (usually Connection Reset by Peer) 21 | from) 22 | (when connection 23 | (handler-case 24 | (progn 25 | (setq from (or (socket:ipaddr-to-hostname 26 | (socket:remote-host connection)) 27 | (socket:ipaddr-to-dotted 28 | (socket:remote-host connection)))) 29 | (logit-stamp "telnet server: new connection from ~a~%" 30 | from) 31 | (setf (eol-convention connection) :dos) 32 | (format connection " 33 | WARNING: do not use :exit or (exit). Use ~s to quit." 34 | '(quit)) 35 | (force-output connection) 36 | (mp:process-run-function 37 | "telnet session" 38 | 'start-telnet-session connection from)) 39 | (error () 40 | (ignore-errors (close connection))))))) 41 | (ignore-errors (close socket)))))) 42 | 43 | 44 | (defvar *in-telnet-session* nil) 45 | 46 | (defun start-telnet-session (s from) 47 | (unwind-protect 48 | (catch 'end-telnet-session 49 | (let ((*in-telnet-session* t)) 50 | (setq excl::*set-acl-running-mutex* nil) 51 | (tpl:start-interactive-top-level 52 | s 'tpl:top-level-read-eval-print-loop nil))) 53 | (ignore-errors (close s))) 54 | (logit-stamp "telnet server: closing connection from ~a~%" from)) 55 | 56 | (defun quit () 57 | (throw 'end-telnet-session nil)) 58 | 59 | (defvar *exit-wrapped* nil) 60 | 61 | (when (not *exit-wrapped*) 62 | (flet ((msg () 63 | (format t "Use ~s instead of exit.~%" '(quit)))) 64 | (def-fwrapper exit-wrapper (&optional status &rest args) 65 | (declare (ignore args)) 66 | (if* *in-telnet-session* 67 | then (msg) 68 | else (call-next-fwrapper))) 69 | 70 | (fwrap 'excl:exit :telnet-server 'exit-wrapper) 71 | (fwrap 'tpl::exit-command :telnet-server 'exit-wrapper))) 72 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | /genfiles 2 | /genfiles.exe 3 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS=-Wall -Wextra 2 | 3 | default: 4 | @echo No default; exit 1 5 | 6 | testnfs: testnfs.c 7 | 8 | genfiles: genfiles.c 9 | 10 | tags: 11 | etags *.[ch] 12 | -------------------------------------------------------------------------------- /test/bigfile-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Test reads and writes over 4GB 3 | 4 | set -eu 5 | 6 | localdir=$1 7 | nfsdir=$2 8 | 9 | tempfile="tempfile.$$" 10 | 11 | trap "rm -f $localdir/$tempfile $nfsdir/$tempfile" EXIT 12 | 13 | echo "create remote file over 4Gig..." 14 | dd if=/dev/zero of=$nfsdir/$tempfile bs=1M count=5000 15 | echo "create local file over 4Gig..." 16 | dd if=/dev/zero of=$localdir/$tempfile bs=1M count=5000 17 | 18 | echo "compare files..." 19 | if ! cmp $localdir/$tempfile $nfsdir/$tempfile; then 20 | echo ERROR: big file of zeros differ 21 | exit 1 22 | fi 23 | -------------------------------------------------------------------------------- /test/genfiles.c: -------------------------------------------------------------------------------- 1 | /* 2 | ** genfiles :: generate test files for performance testing 3 | ** 4 | ** usage: genfiles.exe count 5 | ** 6 | ** `count' is the number of files to create in the current directory. 7 | ** They are named "file%d" where %d is a sequence number from 0 to count-1. 8 | */ 9 | 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | 19 | void generate(char *filename) 20 | { 21 | int fd, n; 22 | const char *contents = "nothing to see here, move along.\n"; 23 | if ((fd = open(filename, O_CREAT|O_RDWR, 0644)) < 0) { 24 | fprintf(stderr, "Could not create %s: %s\n", filename, 25 | strerror(errno)); 26 | exit(1); 27 | } 28 | if ((n = write(fd, contents, strlen(contents))) < 0) { 29 | fprintf(stderr, "write failed: %d: %s\n", n, strerror(errno)); 30 | exit(1); 31 | } 32 | close(fd); 33 | } 34 | 35 | int main(int argc, char **argv) 36 | { 37 | int i; 38 | int max; 39 | char filename[1024]; 40 | 41 | if (argc != 2) { 42 | fprintf(stderr, "usage: %s count\n", argv[0]); 43 | exit(1); 44 | } 45 | 46 | max = atoi(argv[1]); 47 | 48 | for (i = 0; i < max; i++) { 49 | sprintf(filename, "file%d", i); 50 | generate(filename); 51 | } 52 | exit(0); 53 | } 54 | -------------------------------------------------------------------------------- /test/hammernfs-libs/compat.h: -------------------------------------------------------------------------------- 1 | #if defined(__CYGWIN__) || defined(__APPLE__) 2 | 3 | #define xdr_uint64_t xdr_u_int64_t 4 | 5 | #endif 6 | -------------------------------------------------------------------------------- /test/hammernfs-libs/mount.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Please do not edit this file. 3 | * It was generated using rpcgen. 4 | */ 5 | 6 | #ifndef _MOUNT_H_RPCGEN 7 | #define _MOUNT_H_RPCGEN 8 | 9 | #include 10 | 11 | 12 | #ifdef __cplusplus 13 | extern "C" { 14 | #endif 15 | 16 | #define MNTPATHLEN 1024 17 | #define MNTNAMLEN 255 18 | #define FHSIZE 32 19 | 20 | typedef char fhandle[FHSIZE]; 21 | 22 | struct fhstatus { 23 | u_int fhs_status; 24 | union { 25 | fhandle fhs_fhandle; 26 | } fhstatus_u; 27 | }; 28 | typedef struct fhstatus fhstatus; 29 | 30 | typedef char *dirpath; 31 | 32 | typedef char *name; 33 | 34 | typedef struct mountbody *mountlist; 35 | 36 | struct mountbody { 37 | name ml_hostname; 38 | dirpath ml_directory; 39 | mountlist ml_next; 40 | }; 41 | typedef struct mountbody mountbody; 42 | 43 | typedef struct groupnode *groups; 44 | 45 | struct groupnode { 46 | name gr_name; 47 | groups gr_next; 48 | }; 49 | typedef struct groupnode groupnode; 50 | 51 | typedef struct exportnode *exports; 52 | 53 | struct exportnode { 54 | dirpath ex_dir; 55 | groups ex_groups; 56 | exports ex_next; 57 | }; 58 | typedef struct exportnode exportnode; 59 | #define FHSIZE3 64 60 | 61 | typedef struct { 62 | u_int fhandle3_len; 63 | char *fhandle3_val; 64 | } fhandle3; 65 | 66 | enum mountstat3 { 67 | MNT3_OK = 0, 68 | MNT3ERR_PERM = 1, 69 | MNT3ERR_NOENT = 2, 70 | MNT3ERR_IO = 5, 71 | MNT3ERR_ACCES = 13, 72 | MNT3ERR_NOTDIR = 20, 73 | MNT3ERR_INVAL = 22, 74 | MNT3ERR_NAMETOOLONG = 63, 75 | MNT3ERR_NOTSUPP = 10004, 76 | MNT3ERR_SERVERFAULT = 10006, 77 | }; 78 | typedef enum mountstat3 mountstat3; 79 | 80 | struct mountres3_ok { 81 | fhandle3 fhandle; 82 | struct { 83 | u_int auth_flavors_len; 84 | int *auth_flavors_val; 85 | } auth_flavors; 86 | }; 87 | typedef struct mountres3_ok mountres3_ok; 88 | 89 | struct mountres3 { 90 | mountstat3 fhs_status; 91 | union { 92 | mountres3_ok mountinfo; 93 | } mountres3_u; 94 | }; 95 | typedef struct mountres3 mountres3; 96 | 97 | #define MOUNTPROG 100005 98 | #define MOUNTVERS 1 99 | 100 | #if defined(__STDC__) || defined(__cplusplus) 101 | #define MOUNTPROC_NULL 0 102 | extern void * mountproc_null_1(void *, CLIENT *); 103 | extern void * mountproc_null_1_svc(void *, struct svc_req *); 104 | #define MOUNTPROC_MNT 1 105 | extern fhstatus * mountproc_mnt_1(dirpath *, CLIENT *); 106 | extern fhstatus * mountproc_mnt_1_svc(dirpath *, struct svc_req *); 107 | #define MOUNTPROC_DUMP 2 108 | extern mountlist * mountproc_dump_1(void *, CLIENT *); 109 | extern mountlist * mountproc_dump_1_svc(void *, struct svc_req *); 110 | #define MOUNTPROC_UMNT 3 111 | extern void * mountproc_umnt_1(dirpath *, CLIENT *); 112 | extern void * mountproc_umnt_1_svc(dirpath *, struct svc_req *); 113 | #define MOUNTPROC_UMNTALL 4 114 | extern void * mountproc_umntall_1(void *, CLIENT *); 115 | extern void * mountproc_umntall_1_svc(void *, struct svc_req *); 116 | #define MOUNTPROC_EXPORT 5 117 | extern exports * mountproc_export_1(void *, CLIENT *); 118 | extern exports * mountproc_export_1_svc(void *, struct svc_req *); 119 | #define MOUNTPROC_EXPORTALL 6 120 | extern exports * mountproc_exportall_1(void *, CLIENT *); 121 | extern exports * mountproc_exportall_1_svc(void *, struct svc_req *); 122 | extern int mountprog_1_freeresult (SVCXPRT *, xdrproc_t, caddr_t); 123 | 124 | #else /* K&R C */ 125 | #define MOUNTPROC_NULL 0 126 | extern void * mountproc_null_1(); 127 | extern void * mountproc_null_1_svc(); 128 | #define MOUNTPROC_MNT 1 129 | extern fhstatus * mountproc_mnt_1(); 130 | extern fhstatus * mountproc_mnt_1_svc(); 131 | #define MOUNTPROC_DUMP 2 132 | extern mountlist * mountproc_dump_1(); 133 | extern mountlist * mountproc_dump_1_svc(); 134 | #define MOUNTPROC_UMNT 3 135 | extern void * mountproc_umnt_1(); 136 | extern void * mountproc_umnt_1_svc(); 137 | #define MOUNTPROC_UMNTALL 4 138 | extern void * mountproc_umntall_1(); 139 | extern void * mountproc_umntall_1_svc(); 140 | #define MOUNTPROC_EXPORT 5 141 | extern exports * mountproc_export_1(); 142 | extern exports * mountproc_export_1_svc(); 143 | #define MOUNTPROC_EXPORTALL 6 144 | extern exports * mountproc_exportall_1(); 145 | extern exports * mountproc_exportall_1_svc(); 146 | extern int mountprog_1_freeresult (); 147 | #endif /* K&R C */ 148 | #define MOUNT_V3 3 149 | 150 | #if defined(__STDC__) || defined(__cplusplus) 151 | #define MOUNTPROC3_NULL 0 152 | extern void * mountproc3_null_3(void *, CLIENT *); 153 | extern void * mountproc3_null_3_svc(void *, struct svc_req *); 154 | #define MOUNTPROC3_MNT 1 155 | extern mountres3 * mountproc3_mnt_3(dirpath *, CLIENT *); 156 | extern mountres3 * mountproc3_mnt_3_svc(dirpath *, struct svc_req *); 157 | #define MOUNTPROC3_DUMP 2 158 | extern mountlist * mountproc3_dump_3(void *, CLIENT *); 159 | extern mountlist * mountproc3_dump_3_svc(void *, struct svc_req *); 160 | #define MOUNTPROC3_UMNT 3 161 | extern void * mountproc3_umnt_3(dirpath *, CLIENT *); 162 | extern void * mountproc3_umnt_3_svc(dirpath *, struct svc_req *); 163 | #define MOUNTPROC3_UMNTALL 4 164 | extern void * mountproc3_umntall_3(void *, CLIENT *); 165 | extern void * mountproc3_umntall_3_svc(void *, struct svc_req *); 166 | #define MOUNTPROC3_EXPORT 5 167 | extern exports * mountproc3_export_3(void *, CLIENT *); 168 | extern exports * mountproc3_export_3_svc(void *, struct svc_req *); 169 | extern int mountprog_3_freeresult (SVCXPRT *, xdrproc_t, caddr_t); 170 | 171 | #else /* K&R C */ 172 | #define MOUNTPROC3_NULL 0 173 | extern void * mountproc3_null_3(); 174 | extern void * mountproc3_null_3_svc(); 175 | #define MOUNTPROC3_MNT 1 176 | extern mountres3 * mountproc3_mnt_3(); 177 | extern mountres3 * mountproc3_mnt_3_svc(); 178 | #define MOUNTPROC3_DUMP 2 179 | extern mountlist * mountproc3_dump_3(); 180 | extern mountlist * mountproc3_dump_3_svc(); 181 | #define MOUNTPROC3_UMNT 3 182 | extern void * mountproc3_umnt_3(); 183 | extern void * mountproc3_umnt_3_svc(); 184 | #define MOUNTPROC3_UMNTALL 4 185 | extern void * mountproc3_umntall_3(); 186 | extern void * mountproc3_umntall_3_svc(); 187 | #define MOUNTPROC3_EXPORT 5 188 | extern exports * mountproc3_export_3(); 189 | extern exports * mountproc3_export_3_svc(); 190 | extern int mountprog_3_freeresult (); 191 | #endif /* K&R C */ 192 | 193 | /* the xdr functions */ 194 | 195 | #if defined(__STDC__) || defined(__cplusplus) 196 | extern bool_t xdr_fhandle (XDR *, fhandle); 197 | extern bool_t xdr_fhstatus (XDR *, fhstatus*); 198 | extern bool_t xdr_dirpath (XDR *, dirpath*); 199 | extern bool_t xdr_name (XDR *, name*); 200 | extern bool_t xdr_mountlist (XDR *, mountlist*); 201 | extern bool_t xdr_mountbody (XDR *, mountbody*); 202 | extern bool_t xdr_groups (XDR *, groups*); 203 | extern bool_t xdr_groupnode (XDR *, groupnode*); 204 | extern bool_t xdr_exports (XDR *, exports*); 205 | extern bool_t xdr_exportnode (XDR *, exportnode*); 206 | extern bool_t xdr_fhandle3 (XDR *, fhandle3*); 207 | extern bool_t xdr_mountstat3 (XDR *, mountstat3*); 208 | extern bool_t xdr_mountres3_ok (XDR *, mountres3_ok*); 209 | extern bool_t xdr_mountres3 (XDR *, mountres3*); 210 | 211 | #else /* K&R C */ 212 | extern bool_t xdr_fhandle (); 213 | extern bool_t xdr_fhstatus (); 214 | extern bool_t xdr_dirpath (); 215 | extern bool_t xdr_name (); 216 | extern bool_t xdr_mountlist (); 217 | extern bool_t xdr_mountbody (); 218 | extern bool_t xdr_groups (); 219 | extern bool_t xdr_groupnode (); 220 | extern bool_t xdr_exports (); 221 | extern bool_t xdr_exportnode (); 222 | extern bool_t xdr_fhandle3 (); 223 | extern bool_t xdr_mountstat3 (); 224 | extern bool_t xdr_mountres3_ok (); 225 | extern bool_t xdr_mountres3 (); 226 | 227 | #endif /* K&R C */ 228 | 229 | #ifdef __cplusplus 230 | } 231 | #endif 232 | 233 | #endif /* !_MOUNT_H_RPCGEN */ 234 | -------------------------------------------------------------------------------- /test/hammernfs-libs/mount_clnt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Please do not edit this file. 3 | * It was generated using rpcgen. 4 | */ 5 | 6 | #include /* for memset */ 7 | #include "mount.h" 8 | 9 | /* Default timeout can be changed using clnt_control() */ 10 | static struct timeval TIMEOUT = { 25, 0 }; 11 | 12 | void * 13 | mountproc_null_1(void *argp, CLIENT *clnt) 14 | { 15 | static char clnt_res; 16 | 17 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 18 | if (clnt_call (clnt, MOUNTPROC_NULL, 19 | (xdrproc_t) xdr_void, (caddr_t) argp, 20 | (xdrproc_t) xdr_void, (caddr_t) &clnt_res, 21 | TIMEOUT) != RPC_SUCCESS) { 22 | return (NULL); 23 | } 24 | return ((void *)&clnt_res); 25 | } 26 | 27 | fhstatus * 28 | mountproc_mnt_1(dirpath *argp, CLIENT *clnt) 29 | { 30 | static fhstatus clnt_res; 31 | 32 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 33 | if (clnt_call (clnt, MOUNTPROC_MNT, 34 | (xdrproc_t) xdr_dirpath, (caddr_t) argp, 35 | (xdrproc_t) xdr_fhstatus, (caddr_t) &clnt_res, 36 | TIMEOUT) != RPC_SUCCESS) { 37 | return (NULL); 38 | } 39 | return (&clnt_res); 40 | } 41 | 42 | mountlist * 43 | mountproc_dump_1(void *argp, CLIENT *clnt) 44 | { 45 | static mountlist clnt_res; 46 | 47 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 48 | if (clnt_call (clnt, MOUNTPROC_DUMP, 49 | (xdrproc_t) xdr_void, (caddr_t) argp, 50 | (xdrproc_t) xdr_mountlist, (caddr_t) &clnt_res, 51 | TIMEOUT) != RPC_SUCCESS) { 52 | return (NULL); 53 | } 54 | return (&clnt_res); 55 | } 56 | 57 | void * 58 | mountproc_umnt_1(dirpath *argp, CLIENT *clnt) 59 | { 60 | static char clnt_res; 61 | 62 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 63 | if (clnt_call (clnt, MOUNTPROC_UMNT, 64 | (xdrproc_t) xdr_dirpath, (caddr_t) argp, 65 | (xdrproc_t) xdr_void, (caddr_t) &clnt_res, 66 | TIMEOUT) != RPC_SUCCESS) { 67 | return (NULL); 68 | } 69 | return ((void *)&clnt_res); 70 | } 71 | 72 | void * 73 | mountproc_umntall_1(void *argp, CLIENT *clnt) 74 | { 75 | static char clnt_res; 76 | 77 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 78 | if (clnt_call (clnt, MOUNTPROC_UMNTALL, 79 | (xdrproc_t) xdr_void, (caddr_t) argp, 80 | (xdrproc_t) xdr_void, (caddr_t) &clnt_res, 81 | TIMEOUT) != RPC_SUCCESS) { 82 | return (NULL); 83 | } 84 | return ((void *)&clnt_res); 85 | } 86 | 87 | exports * 88 | mountproc_export_1(void *argp, CLIENT *clnt) 89 | { 90 | static exports clnt_res; 91 | 92 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 93 | if (clnt_call (clnt, MOUNTPROC_EXPORT, 94 | (xdrproc_t) xdr_void, (caddr_t) argp, 95 | (xdrproc_t) xdr_exports, (caddr_t) &clnt_res, 96 | TIMEOUT) != RPC_SUCCESS) { 97 | return (NULL); 98 | } 99 | return (&clnt_res); 100 | } 101 | 102 | exports * 103 | mountproc_exportall_1(void *argp, CLIENT *clnt) 104 | { 105 | static exports clnt_res; 106 | 107 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 108 | if (clnt_call (clnt, MOUNTPROC_EXPORTALL, 109 | (xdrproc_t) xdr_void, (caddr_t) argp, 110 | (xdrproc_t) xdr_exports, (caddr_t) &clnt_res, 111 | TIMEOUT) != RPC_SUCCESS) { 112 | return (NULL); 113 | } 114 | return (&clnt_res); 115 | } 116 | 117 | void * 118 | mountproc3_null_3(void *argp, CLIENT *clnt) 119 | { 120 | static char clnt_res; 121 | 122 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 123 | if (clnt_call (clnt, MOUNTPROC3_NULL, 124 | (xdrproc_t) xdr_void, (caddr_t) argp, 125 | (xdrproc_t) xdr_void, (caddr_t) &clnt_res, 126 | TIMEOUT) != RPC_SUCCESS) { 127 | return (NULL); 128 | } 129 | return ((void *)&clnt_res); 130 | } 131 | 132 | mountres3 * 133 | mountproc3_mnt_3(dirpath *argp, CLIENT *clnt) 134 | { 135 | static mountres3 clnt_res; 136 | 137 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 138 | if (clnt_call (clnt, MOUNTPROC3_MNT, 139 | (xdrproc_t) xdr_dirpath, (caddr_t) argp, 140 | (xdrproc_t) xdr_mountres3, (caddr_t) &clnt_res, 141 | TIMEOUT) != RPC_SUCCESS) { 142 | return (NULL); 143 | } 144 | return (&clnt_res); 145 | } 146 | 147 | mountlist * 148 | mountproc3_dump_3(void *argp, CLIENT *clnt) 149 | { 150 | static mountlist clnt_res; 151 | 152 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 153 | if (clnt_call (clnt, MOUNTPROC3_DUMP, 154 | (xdrproc_t) xdr_void, (caddr_t) argp, 155 | (xdrproc_t) xdr_mountlist, (caddr_t) &clnt_res, 156 | TIMEOUT) != RPC_SUCCESS) { 157 | return (NULL); 158 | } 159 | return (&clnt_res); 160 | } 161 | 162 | void * 163 | mountproc3_umnt_3(dirpath *argp, CLIENT *clnt) 164 | { 165 | static char clnt_res; 166 | 167 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 168 | if (clnt_call (clnt, MOUNTPROC3_UMNT, 169 | (xdrproc_t) xdr_dirpath, (caddr_t) argp, 170 | (xdrproc_t) xdr_void, (caddr_t) &clnt_res, 171 | TIMEOUT) != RPC_SUCCESS) { 172 | return (NULL); 173 | } 174 | return ((void *)&clnt_res); 175 | } 176 | 177 | void * 178 | mountproc3_umntall_3(void *argp, CLIENT *clnt) 179 | { 180 | static char clnt_res; 181 | 182 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 183 | if (clnt_call (clnt, MOUNTPROC3_UMNTALL, 184 | (xdrproc_t) xdr_void, (caddr_t) argp, 185 | (xdrproc_t) xdr_void, (caddr_t) &clnt_res, 186 | TIMEOUT) != RPC_SUCCESS) { 187 | return (NULL); 188 | } 189 | return ((void *)&clnt_res); 190 | } 191 | 192 | exports * 193 | mountproc3_export_3(void *argp, CLIENT *clnt) 194 | { 195 | static exports clnt_res; 196 | 197 | memset((char *)&clnt_res, 0, sizeof(clnt_res)); 198 | if (clnt_call (clnt, MOUNTPROC3_EXPORT, 199 | (xdrproc_t) xdr_void, (caddr_t) argp, 200 | (xdrproc_t) xdr_exports, (caddr_t) &clnt_res, 201 | TIMEOUT) != RPC_SUCCESS) { 202 | return (NULL); 203 | } 204 | return (&clnt_res); 205 | } 206 | -------------------------------------------------------------------------------- /test/hammernfs-libs/mount_svc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Please do not edit this file. 3 | * It was generated using rpcgen. 4 | */ 5 | 6 | #include "mount.h" 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | #ifndef SIG_PF 16 | #define SIG_PF void(*)(int) 17 | #endif 18 | 19 | static void 20 | mountprog_1(struct svc_req *rqstp, register SVCXPRT *transp) 21 | { 22 | union { 23 | dirpath mountproc_mnt_1_arg; 24 | dirpath mountproc_umnt_1_arg; 25 | } argument; 26 | char *result; 27 | xdrproc_t _xdr_argument, _xdr_result; 28 | char *(*local)(char *, struct svc_req *); 29 | 30 | switch (rqstp->rq_proc) { 31 | case MOUNTPROC_NULL: 32 | _xdr_argument = (xdrproc_t) xdr_void; 33 | _xdr_result = (xdrproc_t) xdr_void; 34 | local = (char *(*)(char *, struct svc_req *)) mountproc_null_1_svc; 35 | break; 36 | 37 | case MOUNTPROC_MNT: 38 | _xdr_argument = (xdrproc_t) xdr_dirpath; 39 | _xdr_result = (xdrproc_t) xdr_fhstatus; 40 | local = (char *(*)(char *, struct svc_req *)) mountproc_mnt_1_svc; 41 | break; 42 | 43 | case MOUNTPROC_DUMP: 44 | _xdr_argument = (xdrproc_t) xdr_void; 45 | _xdr_result = (xdrproc_t) xdr_mountlist; 46 | local = (char *(*)(char *, struct svc_req *)) mountproc_dump_1_svc; 47 | break; 48 | 49 | case MOUNTPROC_UMNT: 50 | _xdr_argument = (xdrproc_t) xdr_dirpath; 51 | _xdr_result = (xdrproc_t) xdr_void; 52 | local = (char *(*)(char *, struct svc_req *)) mountproc_umnt_1_svc; 53 | break; 54 | 55 | case MOUNTPROC_UMNTALL: 56 | _xdr_argument = (xdrproc_t) xdr_void; 57 | _xdr_result = (xdrproc_t) xdr_void; 58 | local = (char *(*)(char *, struct svc_req *)) mountproc_umntall_1_svc; 59 | break; 60 | 61 | case MOUNTPROC_EXPORT: 62 | _xdr_argument = (xdrproc_t) xdr_void; 63 | _xdr_result = (xdrproc_t) xdr_exports; 64 | local = (char *(*)(char *, struct svc_req *)) mountproc_export_1_svc; 65 | break; 66 | 67 | case MOUNTPROC_EXPORTALL: 68 | _xdr_argument = (xdrproc_t) xdr_void; 69 | _xdr_result = (xdrproc_t) xdr_exports; 70 | local = (char *(*)(char *, struct svc_req *)) mountproc_exportall_1_svc; 71 | break; 72 | 73 | default: 74 | svcerr_noproc (transp); 75 | return; 76 | } 77 | memset ((char *)&argument, 0, sizeof (argument)); 78 | if (!svc_getargs (transp, (xdrproc_t) _xdr_argument, (caddr_t) &argument)) { 79 | svcerr_decode (transp); 80 | return; 81 | } 82 | result = (*local)((char *)&argument, rqstp); 83 | if (result != NULL && !svc_sendreply(transp, (xdrproc_t) _xdr_result, result)) { 84 | svcerr_systemerr (transp); 85 | } 86 | if (!svc_freeargs (transp, (xdrproc_t) _xdr_argument, (caddr_t) &argument)) { 87 | fprintf (stderr, "%s", "unable to free arguments"); 88 | exit (1); 89 | } 90 | return; 91 | } 92 | 93 | static void 94 | mountprog_3(struct svc_req *rqstp, register SVCXPRT *transp) 95 | { 96 | union { 97 | dirpath mountproc3_mnt_3_arg; 98 | dirpath mountproc3_umnt_3_arg; 99 | } argument; 100 | char *result; 101 | xdrproc_t _xdr_argument, _xdr_result; 102 | char *(*local)(char *, struct svc_req *); 103 | 104 | switch (rqstp->rq_proc) { 105 | case MOUNTPROC3_NULL: 106 | _xdr_argument = (xdrproc_t) xdr_void; 107 | _xdr_result = (xdrproc_t) xdr_void; 108 | local = (char *(*)(char *, struct svc_req *)) mountproc3_null_3_svc; 109 | break; 110 | 111 | case MOUNTPROC3_MNT: 112 | _xdr_argument = (xdrproc_t) xdr_dirpath; 113 | _xdr_result = (xdrproc_t) xdr_mountres3; 114 | local = (char *(*)(char *, struct svc_req *)) mountproc3_mnt_3_svc; 115 | break; 116 | 117 | case MOUNTPROC3_DUMP: 118 | _xdr_argument = (xdrproc_t) xdr_void; 119 | _xdr_result = (xdrproc_t) xdr_mountlist; 120 | local = (char *(*)(char *, struct svc_req *)) mountproc3_dump_3_svc; 121 | break; 122 | 123 | case MOUNTPROC3_UMNT: 124 | _xdr_argument = (xdrproc_t) xdr_dirpath; 125 | _xdr_result = (xdrproc_t) xdr_void; 126 | local = (char *(*)(char *, struct svc_req *)) mountproc3_umnt_3_svc; 127 | break; 128 | 129 | case MOUNTPROC3_UMNTALL: 130 | _xdr_argument = (xdrproc_t) xdr_void; 131 | _xdr_result = (xdrproc_t) xdr_void; 132 | local = (char *(*)(char *, struct svc_req *)) mountproc3_umntall_3_svc; 133 | break; 134 | 135 | case MOUNTPROC3_EXPORT: 136 | _xdr_argument = (xdrproc_t) xdr_void; 137 | _xdr_result = (xdrproc_t) xdr_exports; 138 | local = (char *(*)(char *, struct svc_req *)) mountproc3_export_3_svc; 139 | break; 140 | 141 | default: 142 | svcerr_noproc (transp); 143 | return; 144 | } 145 | memset ((char *)&argument, 0, sizeof (argument)); 146 | if (!svc_getargs (transp, (xdrproc_t) _xdr_argument, (caddr_t) &argument)) { 147 | svcerr_decode (transp); 148 | return; 149 | } 150 | result = (*local)((char *)&argument, rqstp); 151 | if (result != NULL && !svc_sendreply(transp, (xdrproc_t) _xdr_result, result)) { 152 | svcerr_systemerr (transp); 153 | } 154 | if (!svc_freeargs (transp, (xdrproc_t) _xdr_argument, (caddr_t) &argument)) { 155 | fprintf (stderr, "%s", "unable to free arguments"); 156 | exit (1); 157 | } 158 | return; 159 | } 160 | 161 | int 162 | main (int argc, char **argv) 163 | { 164 | register SVCXPRT *transp; 165 | 166 | pmap_unset (MOUNTPROG, MOUNTVERS); 167 | pmap_unset (MOUNTPROG, MOUNT_V3); 168 | 169 | transp = svcudp_create(RPC_ANYSOCK); 170 | if (transp == NULL) { 171 | fprintf (stderr, "%s", "cannot create udp service."); 172 | exit(1); 173 | } 174 | if (!svc_register(transp, MOUNTPROG, MOUNTVERS, mountprog_1, IPPROTO_UDP)) { 175 | fprintf (stderr, "%s", "unable to register (MOUNTPROG, MOUNTVERS, udp)."); 176 | exit(1); 177 | } 178 | if (!svc_register(transp, MOUNTPROG, MOUNT_V3, mountprog_3, IPPROTO_UDP)) { 179 | fprintf (stderr, "%s", "unable to register (MOUNTPROG, MOUNT_V3, udp)."); 180 | exit(1); 181 | } 182 | 183 | transp = svctcp_create(RPC_ANYSOCK, 0, 0); 184 | if (transp == NULL) { 185 | fprintf (stderr, "%s", "cannot create tcp service."); 186 | exit(1); 187 | } 188 | if (!svc_register(transp, MOUNTPROG, MOUNTVERS, mountprog_1, IPPROTO_TCP)) { 189 | fprintf (stderr, "%s", "unable to register (MOUNTPROG, MOUNTVERS, tcp)."); 190 | exit(1); 191 | } 192 | if (!svc_register(transp, MOUNTPROG, MOUNT_V3, mountprog_3, IPPROTO_TCP)) { 193 | fprintf (stderr, "%s", "unable to register (MOUNTPROG, MOUNT_V3, tcp)."); 194 | exit(1); 195 | } 196 | 197 | svc_run (); 198 | fprintf (stderr, "%s", "svc_run returned"); 199 | exit (1); 200 | /* NOTREACHED */ 201 | } 202 | -------------------------------------------------------------------------------- /test/hammernfs-libs/mount_xdr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Please do not edit this file. 3 | * It was generated using rpcgen. 4 | */ 5 | 6 | #include "mount.h" 7 | 8 | bool_t 9 | xdr_fhandle (XDR *xdrs, fhandle objp) 10 | { 11 | register int32_t *buf; 12 | 13 | if (!xdr_opaque (xdrs, objp, FHSIZE)) 14 | return FALSE; 15 | return TRUE; 16 | } 17 | 18 | bool_t 19 | xdr_fhstatus (XDR *xdrs, fhstatus *objp) 20 | { 21 | register int32_t *buf; 22 | 23 | if (!xdr_u_int (xdrs, &objp->fhs_status)) 24 | return FALSE; 25 | switch (objp->fhs_status) { 26 | case 0: 27 | if (!xdr_fhandle (xdrs, objp->fhstatus_u.fhs_fhandle)) 28 | return FALSE; 29 | break; 30 | default: 31 | break; 32 | } 33 | return TRUE; 34 | } 35 | 36 | bool_t 37 | xdr_dirpath (XDR *xdrs, dirpath *objp) 38 | { 39 | register int32_t *buf; 40 | 41 | if (!xdr_string (xdrs, objp, MNTPATHLEN)) 42 | return FALSE; 43 | return TRUE; 44 | } 45 | 46 | bool_t 47 | xdr_name (XDR *xdrs, name *objp) 48 | { 49 | register int32_t *buf; 50 | 51 | if (!xdr_string (xdrs, objp, MNTNAMLEN)) 52 | return FALSE; 53 | return TRUE; 54 | } 55 | 56 | bool_t 57 | xdr_mountlist (XDR *xdrs, mountlist *objp) 58 | { 59 | register int32_t *buf; 60 | 61 | if (!xdr_pointer (xdrs, (char **)objp, sizeof (struct mountbody), (xdrproc_t) xdr_mountbody)) 62 | return FALSE; 63 | return TRUE; 64 | } 65 | 66 | bool_t 67 | xdr_mountbody (XDR *xdrs, mountbody *objp) 68 | { 69 | register int32_t *buf; 70 | 71 | if (!xdr_name (xdrs, &objp->ml_hostname)) 72 | return FALSE; 73 | if (!xdr_dirpath (xdrs, &objp->ml_directory)) 74 | return FALSE; 75 | if (!xdr_mountlist (xdrs, &objp->ml_next)) 76 | return FALSE; 77 | return TRUE; 78 | } 79 | 80 | bool_t 81 | xdr_groups (XDR *xdrs, groups *objp) 82 | { 83 | register int32_t *buf; 84 | 85 | if (!xdr_pointer (xdrs, (char **)objp, sizeof (struct groupnode), (xdrproc_t) xdr_groupnode)) 86 | return FALSE; 87 | return TRUE; 88 | } 89 | 90 | bool_t 91 | xdr_groupnode (XDR *xdrs, groupnode *objp) 92 | { 93 | register int32_t *buf; 94 | 95 | if (!xdr_name (xdrs, &objp->gr_name)) 96 | return FALSE; 97 | if (!xdr_groups (xdrs, &objp->gr_next)) 98 | return FALSE; 99 | return TRUE; 100 | } 101 | 102 | bool_t 103 | xdr_exports (XDR *xdrs, exports *objp) 104 | { 105 | register int32_t *buf; 106 | 107 | if (!xdr_pointer (xdrs, (char **)objp, sizeof (struct exportnode), (xdrproc_t) xdr_exportnode)) 108 | return FALSE; 109 | return TRUE; 110 | } 111 | 112 | bool_t 113 | xdr_exportnode (XDR *xdrs, exportnode *objp) 114 | { 115 | register int32_t *buf; 116 | 117 | if (!xdr_dirpath (xdrs, &objp->ex_dir)) 118 | return FALSE; 119 | if (!xdr_groups (xdrs, &objp->ex_groups)) 120 | return FALSE; 121 | if (!xdr_exports (xdrs, &objp->ex_next)) 122 | return FALSE; 123 | return TRUE; 124 | } 125 | 126 | bool_t 127 | xdr_fhandle3 (XDR *xdrs, fhandle3 *objp) 128 | { 129 | register int32_t *buf; 130 | 131 | if (!xdr_bytes (xdrs, (char **)&objp->fhandle3_val, (u_int *) &objp->fhandle3_len, FHSIZE3)) 132 | return FALSE; 133 | return TRUE; 134 | } 135 | 136 | bool_t 137 | xdr_mountstat3 (XDR *xdrs, mountstat3 *objp) 138 | { 139 | register int32_t *buf; 140 | 141 | if (!xdr_enum (xdrs, (enum_t *) objp)) 142 | return FALSE; 143 | return TRUE; 144 | } 145 | 146 | bool_t 147 | xdr_mountres3_ok (XDR *xdrs, mountres3_ok *objp) 148 | { 149 | register int32_t *buf; 150 | 151 | if (!xdr_fhandle3 (xdrs, &objp->fhandle)) 152 | return FALSE; 153 | if (!xdr_array (xdrs, (char **)&objp->auth_flavors.auth_flavors_val, (u_int *) &objp->auth_flavors.auth_flavors_len, ~0, 154 | sizeof (int), (xdrproc_t) xdr_int)) 155 | return FALSE; 156 | return TRUE; 157 | } 158 | 159 | bool_t 160 | xdr_mountres3 (XDR *xdrs, mountres3 *objp) 161 | { 162 | register int32_t *buf; 163 | 164 | if (!xdr_mountstat3 (xdrs, &objp->fhs_status)) 165 | return FALSE; 166 | switch (objp->fhs_status) { 167 | case MNT3_OK: 168 | if (!xdr_mountres3_ok (xdrs, &objp->mountres3_u.mountinfo)) 169 | return FALSE; 170 | break; 171 | default: 172 | break; 173 | } 174 | return TRUE; 175 | } 176 | -------------------------------------------------------------------------------- /test/hammernfs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include "nfs-common.h" 12 | 13 | void usage(char *prg) { 14 | fprintf(stderr, "Usage: %s [ -q ] [ -v nfsvers ] [ -t test_duration ] [ -u uid ] [ -g gid ] [ -b blocksize ] [ -p udp|tcp ] [ -i label ] host:/export/path/to/file_to_read\n", prg); 15 | exit(1); 16 | } 17 | 18 | int main(int argc, char **argv) { 19 | struct file_handle *rootfh, *fh; 20 | CLIENT *clnt; 21 | AUTH *auth; 22 | unsigned long long total=0; 23 | int reads=0; 24 | struct timeval starttime, now, elapsed; 25 | double kbps; 26 | char opt; 27 | char myhostname[255]; 28 | 29 | /* Parameters */ 30 | int vers=2; 31 | int duration=60; 32 | int label=0; 33 | int uid=geteuid(), gid=getegid(); 34 | int blocksize=4096; 35 | char *host=NULL; 36 | char *x; 37 | char *testpath=NULL; 38 | char *exportname=NULL; 39 | int quiet = 0; 40 | char *proto="udp"; 41 | 42 | while ((opt=getopt(argc, argv, "i:v:t:u:g:b:qp:"))!=-1) { 43 | switch (opt) { 44 | case 'v': 45 | vers=atoi(optarg); 46 | if (vers != 2 && vers != 3) { 47 | fprintf(stderr, "%s: NFS V%d not supported yet\n", argv[0], vers); 48 | exit(1); 49 | } 50 | break; 51 | case 't': 52 | duration=atoi(optarg); 53 | if (duration < 1) { 54 | fprintf(stderr, "%s: Duration must be greater than zero.\n", argv[0]); 55 | exit(1); 56 | } 57 | break; 58 | case 'q': 59 | quiet = 1; 60 | break; 61 | case 'i': 62 | label=atoi(optarg); 63 | break; 64 | case 'u': 65 | uid=atoi(optarg); 66 | break; 67 | case 'g': 68 | gid=atoi(optarg); 69 | break; 70 | case 'b': 71 | blocksize=atoi(optarg); 72 | break; 73 | case 'p': 74 | if (strcmp(optarg, "udp") !=0 && strcmp(optarg,"tcp") != 0) { 75 | fprintf(stderr, "Invalid protocol: '%s'. Must be udp or tcp.\n", optarg); 76 | exit(1); 77 | } 78 | proto=strdup(optarg); 79 | break; 80 | default: 81 | usage(argv[0]); 82 | } 83 | } 84 | 85 | if (optind >= argc) 86 | usage(argv[0]); 87 | 88 | x=strchr(argv[optind], ':'); 89 | if (!x) 90 | usage(argv[0]); 91 | 92 | *x=0; 93 | 94 | host=argv[optind]; 95 | 96 | exportname=x+1; 97 | 98 | if (!strlen(exportname)) 99 | usage(argv[0]); 100 | 101 | x=strchr(*exportname == '/' ? exportname+1 : exportname , '/'); 102 | if (!x) 103 | usage(argv[0]); 104 | 105 | *x=0; 106 | 107 | testpath=x+1; 108 | if (!strlen(testpath)) 109 | usage(argv[0]); 110 | 111 | if (!strcmp(proto,"udp") && blocksize > 8192) { 112 | fprintf(stderr, "Max NFS blocksize over UDP is 8192\n"); 113 | exit(1); 114 | } 115 | 116 | printf("(\n"); 117 | printf(":export-name \"%s\"\n", exportname); 118 | printf(":testpath \"%s\"\n", testpath); 119 | printf(":iteration %d\n", label); 120 | printf(":nfs-version %d\n", vers); 121 | printf(":blocksize %d ;; in bytes\n", blocksize); 122 | printf(":transport :%s\n", proto); 123 | 124 | gethostname(myhostname, sizeof(myhostname)); 125 | 126 | auth=authunix_create(myhostname, uid, gid, 0, NULL); 127 | 128 | rootfh=get_export_fh(vers, host, exportname, auth); 129 | 130 | clnt=clnt_create_with_retry(host, NFS_PROGRAM, vers, proto); 131 | if (!clnt) { 132 | clnt_pcreateerror("clnt_create failed[3]"); 133 | exit(1); 134 | } 135 | 136 | clnt->cl_auth=auth; 137 | 138 | fh=lookup_path(clnt, rootfh, testpath); 139 | 140 | #if 0 141 | /* Ahmon and I used this to debug the problem in spr43071 and the 142 | * same problem seen by another customer, where when a file is 143 | * deleted we get this error. It required this hackery because most 144 | * NFS clients don't cause the error because when they notice 145 | * there's a problem, they probe the file and find it's been 146 | * deleted. 147 | */ 148 | { 149 | printf("pause to delete file on NFS server host; restart server:"); 150 | getchar(); 151 | nfs_read(clnt, fh, blocksize); 152 | exit(1); 153 | } 154 | #endif 155 | 156 | gettimeofday(&starttime, NULL); 157 | 158 | while (1) { 159 | int count; 160 | 161 | gettimeofday(&now, NULL); 162 | 163 | timeval_subtract(&elapsed, &now, &starttime); 164 | 165 | if (elapsed.tv_sec >= duration) 166 | break; 167 | 168 | count=nfs_read(clnt, fh, blocksize); 169 | total+=count; 170 | reads++; 171 | } 172 | 173 | #ifdef __APPLE__ 174 | printf(":duration %ld.%06d ;; seconds\n", elapsed.tv_sec, elapsed.tv_usec); 175 | #else 176 | printf(":duration %ld.%06ld ;; seconds\n", elapsed.tv_sec, elapsed.tv_usec); 177 | #endif 178 | 179 | printf(":reads %d\n", reads); 180 | printf(":read-bytes %llu\n", total); 181 | kbps=(double)total/timeval_to_seconds(&elapsed)/(double)1024; 182 | printf(":rate %f ;; KB/second\n", kbps); 183 | printf(")\n"); 184 | clnt_destroy(clnt); 185 | 186 | return 0; 187 | } 188 | -------------------------------------------------------------------------------- /test/misc-tests.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env bash 2 | 3 | set -eu 4 | 5 | function die { 6 | [ "${*-}" ] && echo "Error: $*" 1>&2 7 | exit 1 8 | } 9 | 10 | testhost=$1 11 | nfspath=$2 12 | hostpath=$3 13 | 14 | # Make sure we can ls the entire c:/ directory 15 | function test1 { 16 | local count1a="$(ssh $testhost /bin/ls -1 $hostpath | wc -l)" 17 | local count1b="$(/bin/ls -1 $nfspath | wc -l)" 18 | local count2a="$(ssh $testhost /bin/ls -l $hostpath | tail -n +2 | wc -l)" 19 | local count2b="$(/bin/ls -l $nfspath | tail -n +2 | wc -l)" 20 | 21 | [ "$count1a" ] || die count1a is empty 22 | [ "$count1b" ] || die count1b is empty 23 | [ "$count2a" ] || die count2a is empty 24 | [ "$count2b" ] || die count2b is empty 25 | 26 | [ $count1a -eq $count1b ] || die count1 differs 27 | [ $count2a -eq $count2b ] || die count2 differs 28 | [ $count1a -eq $count2a ] || die count1/2 differs: $count1a $count2a 29 | } 30 | 31 | test1 32 | 33 | echo SUCCESS 34 | -------------------------------------------------------------------------------- /test/nfs-common.h: -------------------------------------------------------------------------------- 1 | #include "hammernfs-libs/mount.h" 2 | #include "hammernfs-libs/nfs.h" 3 | 4 | struct file_handle { 5 | int vers; 6 | int len; 7 | unsigned char data[FHSIZE3]; 8 | }; 9 | 10 | void print_fh(struct file_handle *fh); 11 | 12 | struct file_handle *copy_file_handle(struct file_handle *fh); 13 | 14 | CLIENT *clnt_create_with_retry(char *host, unsigned long program, 15 | unsigned long version, char *proto); 16 | 17 | struct file_handle *get_export_fh(int vers, char *host, char *export, 18 | AUTH *auth); 19 | 20 | struct file_handle *lookup(CLIENT *clnt, struct file_handle *base, 21 | char *name); 22 | 23 | struct file_handle *lookup_path(CLIENT *clnt, struct file_handle *base, 24 | char *path); 25 | 26 | int nfs_read(CLIENT *clnt, struct file_handle *fh, int count); 27 | 28 | double timeval_to_seconds(struct timeval *tv); 29 | 30 | int timeval_subtract (struct timeval *result, struct timeval *x, struct timeval *y); 31 | 32 | int split_host_and_path(char *string, char **host, char **path, char **complaint); 33 | 34 | -------------------------------------------------------------------------------- /test/performance.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | # Performance testing of the nfs server 3 | 4 | set -eu 5 | 6 | iterations=5 7 | duration=60 8 | 9 | # time to run this script, for usage text: 10 | minutes=$(( iterations * 2 * 4 * 2 * duration / 60 )) 11 | 12 | function usage { 13 | [ "${*-}" ] && echo "Error: $*" 1>&2 14 | cat 1>&2 <&2 34 | exit 1 35 | } 36 | 37 | # hammernfs fails randomly on Cygwin 38 | [ -d c:/ ] && errordie This script is unreliable when run on Windows 39 | 40 | while [ $# -gt 0 ]; do 41 | case $1 in 42 | --help) usage ;; 43 | -*) usage bad argument: $1 ;; 44 | *) [ $# -eq 2 ] || usage wrong number of arguments 45 | break 46 | ;; 47 | esac 48 | shift 49 | done 50 | 51 | if [[ $1 =~ : ]]; then 52 | : 53 | else 54 | errordie nfstestpath should have the form host:path 55 | fi 56 | 57 | nfstestpath=$1 58 | logfile=results/$2 59 | 60 | [ -f "$logfile" ] && errordie $logfile exists 61 | 62 | make hammernfs 63 | hammernfs="./hammernfs" 64 | 65 | [ "$logfile" ] && echo Logging to: $logfile 66 | 67 | host=$(hostname) 68 | 69 | function logit { 70 | if [ "$logfile" ]; then 71 | echo "$@" >> $logfile 72 | else 73 | echo "$@" 74 | fi 75 | } 76 | 77 | [ "$logfile" ] && cp /dev/null $logfile 78 | logit ';;;' performance tests, client host is: $host, $(date) 79 | 80 | function hammertime { 81 | logit ';;' $hammernfs "$@" 82 | echo $hammernfs "$@" 83 | if [ "$logfile" ]; then 84 | $hammernfs "$@" >> $logfile 85 | else 86 | $hammernfs "$@" 87 | fi 88 | } 89 | 90 | for ver in 2 3; do 91 | for bs in 512 2048 4096 8192; do 92 | for transport in tcp udp; do 93 | logit '(' 94 | for i in $(seq 1 $iterations); do 95 | hammertime -i $i -v $ver -t $duration -b $bs \ 96 | -p $transport $nfstestpath 97 | done 98 | logit ')' 99 | done 100 | done 101 | done 102 | -------------------------------------------------------------------------------- /test/results.cl: -------------------------------------------------------------------------------- 1 | #! /fi/cl/10.1/bin/mlisp -#C 2 | 3 | (eval-when (compile eval load) 4 | (require :shell) 5 | (use-package :excl.shell)) 6 | 7 | (in-package :user) 8 | 9 | (eval-when (compile eval load) 10 | (require :osi)) 11 | 12 | (defstruct datum 13 | export-name 14 | testpath 15 | iteration 16 | nfs-version 17 | blocksize 18 | transport 19 | duration 20 | read-bytes 21 | rate 22 | reads) 23 | 24 | (defun read-data-groups (data-file &aux form (res '())) 25 | (with-open-file (s data-file) 26 | (loop 27 | (setq form (read s nil s)) 28 | (when (eq form s) (return (nreverse res))) 29 | (push (mapcar (lambda (x) 30 | (apply #'make-datum x)) 31 | form) 32 | res)))) 33 | 34 | (defun calc-avg-rate (group) 35 | (assert group) 36 | ;; group is a list of datum's and we return the avg rate, ignoring the 37 | ;; high and low rate 38 | (flet ((remove-high-and-low (group) 39 | ;; Toss the low and high rate item 40 | (setq group (sort (copy-list group) #'< :key #'datum-rate)) 41 | (setq group (cdr group)) 42 | (nbutlast group 1))) 43 | (let ((len (length group)) 44 | (group group)) 45 | (when (> (length group) 3) 46 | (setq group (remove-high-and-low group)) 47 | ;; length - 2 (for the 2 items removed) 48 | (decf len 2)) 49 | (/ (reduce #'+ (mapcar #'datum-rate group)) 50 | len)))) 51 | 52 | (defun print-stats (ref new) 53 | (flet ((%change (ref new) 54 | (let* ((diff (- new ref)) 55 | (%change (* 100.0 (/ (abs diff) ref)))) 56 | ;; Since we're dealing with rates, higher is better. 57 | ;; If diff is positive, then the % change is positive (faster), 58 | ;; otherwise it's negative (slower) 59 | (if* (minusp diff) 60 | then ;; slower, show as negative 61 | (- %change) 62 | else ;; Slower, show as positive 63 | %change))) 64 | (datum-pretty-name (datum) 65 | (format nil "NFSv~d/~a, BS=~d" 66 | (datum-nfs-version datum) 67 | (datum-transport datum) 68 | (datum-blocksize datum)))) 69 | (format t "~30a ~20a~%" "" " rates: KB/sec") 70 | (format t "~30a ~10@a ~10@a ~11@a~%" "what" "ref" "new" "%change") 71 | (do* ((ref-groups (read-data-groups ref) 72 | (cdr ref-groups)) 73 | (new-groups (read-data-groups new) 74 | (cdr new-groups)) 75 | (ref-group #1=(car ref-groups) #1#) 76 | (new-group #2=(car new-groups) #2#) 77 | 78 | (ref-rate #3=(and ref-group (calc-avg-rate ref-group)) #3#) 79 | (new-rate #4=(and new-group (calc-avg-rate new-group)) #4#)) 80 | ((null ref-groups) 81 | (when (not (null new-groups)) 82 | (error "new-groups longer than ref-groups: ~s." new-groups))) 83 | (assert (string= (datum-pretty-name (car ref-group)) 84 | (datum-pretty-name (car new-group)))) 85 | (format t "~&") 86 | (format t "~30a ~10,2f ~10,2f ~10,2f%~%" 87 | (datum-pretty-name (car ref-group)) 88 | ref-rate 89 | new-rate 90 | (%change ref-rate new-rate))))) 91 | 92 | #+ignore 93 | (print-stats 94 | "5.1" ; reference results 95 | "6.3.0.rc1" ; test results 96 | ) 97 | 98 | (sys:with-command-line-arguments ("v" verbose) (rest) 99 | (declare (ignore verbose)) 100 | (when (not (eql 2 (length rest))) 101 | (die "expected only 2 arguments")) 102 | (let* ((ref (merge-pathnames (first rest) "results/")) 103 | (new (merge-pathnames (second rest) "results/"))) 104 | (or (probe-file ref) (error-die "~a does not exist." ref)) 105 | (or (probe-file new) (error-die "~a does not exist." new)) 106 | (format t ";; ~a to ~a performance comparison:~%~%" 107 | (first rest) 108 | (second rest)) 109 | (print-stats ref new))) 110 | -------------------------------------------------------------------------------- /test/stress-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # stress test the server 3 | # usage: $0 [number-of-iterations] 4 | # one iteration takes about 1m on freon/thor 5 | 6 | set -eu 7 | 8 | localdir=$1; shift 9 | nfsdir=$1; shift 10 | 11 | function makedata { 12 | # make 100mb of data in $1 13 | local n 14 | mkdir -p $1 15 | for n in $(seq 1 10); do 16 | # would be nice if dd had a -q flag 17 | echo making $1/$n 18 | dd if=/dev/urandom of=$1/file${n}.10m \ 19 | bs=1M count=10 &> /dev/null 20 | echo this is a small file > $1/file${n}.small 21 | done 22 | } 23 | 24 | localroot=$localdir/stress.test 25 | nfsroot=$nfsdir/stress.test 26 | 27 | function cleanup { 28 | echo cleanup 29 | rm -fr $nfsroot 30 | rm -fr $localroot 31 | mkdir $nfsroot 32 | mkdir $localroot 33 | } 34 | 35 | function copy { 36 | echo copy to $2 37 | cp -rp $1 $2 38 | } 39 | 40 | for i in $(seq 1 ${1-1}); do 41 | echo ==================== iteration $i - $(date) 42 | cleanup 43 | makedata $localroot/dir 44 | copy $localroot/dir ${nfsroot}/dir 45 | prev= 46 | for j in $(seq 1 10); do 47 | copy $localroot/dir${prev} ${nfsroot}/dir${j} 48 | copy ${nfsroot}/dir${j} ${localroot}/dir${j} 49 | prev=$j 50 | done 51 | copy ${nfsroot}/dir${j} ${localroot}/dir${j} 52 | echo comparing results 53 | if diff $localroot $nfsroot > /dev/null; then 54 | echo OK 55 | else 56 | echo $localroot and $nfsroot are different 57 | exit 1 58 | fi 59 | done 60 | 61 | cleanup 62 | -------------------------------------------------------------------------------- /test/test-big-readdir-udp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Test for rfe15117 3 | */ 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include "nfs-common.h" 16 | 17 | /* 18 | struct READDIR3args { 19 | nfs_fh3 dir; 20 | cookie3 cookie; 21 | cookieverf3 cookieverf; 22 | count3 count; 23 | }; 24 | */ 25 | 26 | void test_readdir3 (CLIENT *clnt, struct file_handle *fh) { 27 | READDIR3args args; 28 | 29 | memset(&args, 0, sizeof(args)); 30 | 31 | args.dir.data.data_len=fh->len; 32 | args.dir.data.data_val=fh->data; 33 | 34 | args.count=8192; // works 35 | 36 | /* These don't work. We end up getting a RPC_CANTDECODERES status 37 | (Can't decode result) back. The NFS server is returning a correct 38 | response, though. And the Linux NFS client doesn't have any 39 | trouble with the results. I think this issue is a size limit 40 | built into the sunrpc library. Anyway, that problem basically 41 | makes this test program incapable of testing rfe15117, but I'm 42 | leaving this code in place for reference. 43 | */ 44 | 45 | //args.count=65535; 46 | //args.count=16000; 47 | 48 | READDIR3res res; 49 | memset(&res, 0, sizeof(res)); 50 | 51 | struct timeval TIMEOUT = { 25, 0 }; 52 | 53 | enum clnt_stat stat = clnt_call (clnt, NFSPROC3_READDIR, 54 | (xdrproc_t) xdr_READDIR3args, (caddr_t) &args, 55 | (xdrproc_t) xdr_READDIR3res, (caddr_t) &res, 56 | TIMEOUT); 57 | if (stat != RPC_SUCCESS) { 58 | clnt_perror(clnt, "readdir3"); 59 | exit (1); 60 | } 61 | 62 | printf("stat: %d\n", stat); 63 | } 64 | 65 | int main(int argc, char **argv) { 66 | int vers = 3; 67 | CLIENT *clnt; 68 | struct file_handle *rootfh; 69 | 70 | if (argc != 2) { 71 | printf("Usage: %s host:/path/to/directory-with-many-files\n", argv[0]); 72 | exit(1); 73 | } 74 | 75 | setup_client(argv[1], vers, "udp", &clnt, &rootfh); 76 | 77 | test_readdir3(clnt, rootfh); 78 | 79 | clnt_destroy(clnt); 80 | 81 | return 0; 82 | } 83 | -------------------------------------------------------------------------------- /test/test-nfs-low.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Various tests which make direct RPC calls 3 | */ 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include "nfs-common.h" 16 | 17 | struct timeval TIMEOUT = { 25, 0 }; 18 | 19 | // Test bug24843 20 | void test_bogus_volume_guid(CLIENT *clnt, struct file_handle *fh) { 21 | printf("%s\n", __func__); 22 | 23 | #if 0 24 | printf(" Orig file handle: "); 25 | print_fh(fh); 26 | printf("\n"); 27 | #endif 28 | 29 | struct file_handle *mod_fh = copy_file_handle(fh); 30 | /* Modify the volume guid portion of the copied file handle 31 | to trigger the bug. The volume guid begins at offset 4 */ 32 | mod_fh->data[4]++; 33 | 34 | #if 0 35 | printf("Modified file handle: "); 36 | print_fh(mod_fh); 37 | printf("\n"); 38 | #endif 39 | 40 | FSSTAT3args args; 41 | args.fsroot.data.data_len=mod_fh->len; 42 | args.fsroot.data.data_val=mod_fh->data; 43 | 44 | FSSTAT3res res; 45 | memset(&res, 0, sizeof(res)); 46 | 47 | enum clnt_stat stat = clnt_call (clnt, NFSPROC3_FSSTAT, 48 | (xdrproc_t) xdr_FSSTAT3args, (caddr_t) &args, 49 | (xdrproc_t) xdr_FSSTAT3res, (caddr_t) &res, 50 | TIMEOUT); 51 | if (stat != RPC_SUCCESS) { 52 | clnt_perror(clnt, "fsstat3"); 53 | exit (1); 54 | } 55 | 56 | switch (res.status) { 57 | case NFS3ERR_STALE: 58 | /* Since we passed in a deliberately bogus file handle, we expect to 59 | get a stale file handle response. */ 60 | printf("PASS: Got stale nfs file handle response as expected.\n"); 61 | free(mod_fh); 62 | return; 63 | case NFS3_OK: 64 | printf("WTF?! fsstat call succeeded unexpectedly.\n"); 65 | exit(1); 66 | default: 67 | printf("FAIL: Got unexpected status: %d\n", res.status); 68 | exit(1); 69 | } 70 | } 71 | 72 | 73 | int main(int argc, char **argv) { 74 | CLIENT *clnt; 75 | struct file_handle *rootfh; 76 | 77 | if (argc != 2) { 78 | printf("Usage: %s host:/export\n", argv[0]); 79 | exit(1); 80 | } 81 | 82 | /* Prepare an NFSv3/UDP client */ 83 | setup_client(argv[1], 3, "udp", &clnt, &rootfh); 84 | 85 | test_bogus_volume_guid(clnt, rootfh); 86 | 87 | clnt_destroy(clnt); 88 | 89 | return 0; 90 | } 91 | -------------------------------------------------------------------------------- /utf8.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (in-package :user) 5 | 6 | (defmacro mi-to-fixnum (value) 7 | `(comp::ll :mi-to-fixnum ,value)) 8 | 9 | (defmacro mi (value) 10 | `(comp::ll :fixnum-to-mi ,value)) 11 | 12 | (defmacro mi-incf (var &optional (amt 1)) 13 | `(setf ,var (comp::ll :+ ,var (mi ,amt)))) 14 | 15 | (defmacro mi-= (var const) 16 | `(comp::ll := ,var (mi ,const))) 17 | 18 | (defmacro mi-<= (var const) 19 | `(comp::ll :<= ,var (mi ,const))) 20 | 21 | (defmacro mi-sub (expr1 expr2) 22 | `(comp::ll :- ,expr1 ,expr2)) 23 | 24 | (defmacro mi-or (expr1 expr2 &rest exprs) 25 | (if (constantp expr1) 26 | (setf expr1 `(mi ,expr1))) 27 | (if (constantp expr2) 28 | (setf expr2 `(mi ,expr2))) 29 | (if* (zerop (length exprs)) 30 | then `(comp::ll :logior ,expr1 ,expr2) 31 | else `(mi-or (comp::ll :logior ,expr1 ,expr2) ,@exprs))) 32 | 33 | (defmacro mi-and (expr1 expr2) 34 | (if (constantp expr1) 35 | (setf expr1 `(mi ,expr1))) 36 | (if (constantp expr2) 37 | (setf expr2 `(mi ,expr2))) 38 | `(comp::ll :logand ,expr1 ,expr2)) 39 | 40 | (defmacro mi-lsr (value amount) 41 | `(comp::ll :lsr ,value (mi ,amount))) 42 | 43 | (defmacro mi-lsl (value amount) 44 | `(comp::ll :lsl ,value (mi ,amount))) 45 | 46 | (defmacro aref-ubyte-vec (vec) 47 | `(comp::ll :aref-ubyte ,vec (mi #.(sys::mdparam 'comp::md-lvector-data0-norm)))) 48 | 49 | (defmacro aref-uword-vec (vec) 50 | `(comp::ll :aref-uword ,vec (mi #.(sys::mdparam 'comp::md-lvector-data0-norm)))) 51 | 52 | (defmacro aset-byte-vec (vec value) 53 | `(comp::ll :aset-byte ,vec (mi #.(sys::mdparam 'comp::md-lvector-data0-norm)) ,value)) 54 | 55 | (defmacro aset-word-vec (vec value) 56 | `(comp::ll :aset-word ,vec (mi #.(sys::mdparam 'comp::md-lvector-data0-norm)) ,value)) 57 | 58 | ;; Expects 16-bit chars 59 | ;; Returns number of bytes encoded. 60 | (defun string-to-utf8 (string vec pos) 61 | (declare (optimize (speed 3) (safety 0)) 62 | (simple-string string) 63 | ((simple-array (unsigned-byte 8) (*)) vec)) 64 | 65 | (let ((remaining (length string))) 66 | (declare (fixnum remaining)) 67 | 68 | (mi-incf vec pos) 69 | 70 | (let ((orig-vec vec)) 71 | 72 | (while (not (zerop remaining)) 73 | (macrolet ((put (value) 74 | `(progn (aset-byte-vec vec ,value) 75 | (mi-incf vec)))) 76 | (let ((code (aref-uword-vec string))) 77 | (mi-incf string 2) 78 | (decf remaining) 79 | (if* (mi-<= code #x7f) 80 | then ;; simple-ascii 81 | (put code) 82 | elseif (mi-<= code #x7ff) 83 | then ;; two byte encoding 84 | (put (mi-or #xc0 (mi-lsr code 6))) 85 | (put (mi-or #x80 (mi-and #x3f code))) 86 | else ;; three byte encoding 87 | (put (mi-or #xe0 (mi-lsr code 12))) 88 | (put (mi-or #x80 (mi-and #x3f (mi-lsr code 6)))) 89 | (put (mi-or #x80 (mi-and #x3f code))))))) 90 | 91 | (mi-to-fixnum (mi-sub vec orig-vec))))) 92 | 93 | ;; Returns # of characters decoded. 94 | (defun utf8-to-string (vec start len out) 95 | (declare (optimize (speed 3) (safety 0)) 96 | (fixnum len)) 97 | 98 | (mi-incf vec start) 99 | 100 | (let ((orig-out out)) 101 | 102 | (while (not (zerop len)) 103 | (macrolet ((nextbyte () 104 | `(prog1 (aref-ubyte-vec vec) 105 | (mi-incf vec) 106 | (decf len))) 107 | (outchar (code) 108 | `(progn 109 | (aset-word-vec out ,code) 110 | (mi-incf out 2))) 111 | (lowsix (value) 112 | `(mi-and #x3f ,value))) 113 | (let ((b (nextbyte))) 114 | (if* (mi-<= b #x7f) 115 | then (outchar b) 116 | elseif (mi-= (mi-and #xe0 b) #xc0) 117 | then ;; 2 byte encoding 118 | (outchar (mi-or (mi-lsl (mi-and #b11111 b) 6) 119 | (lowsix (nextbyte)))) 120 | else ;; 3 byte encoding 121 | (outchar (mi-or 122 | (mi-lsl (mi-and b #xf) 12) 123 | (mi-lsl (lowsix (nextbyte)) 6) 124 | (lowsix (nextbyte)))))))) 125 | 126 | (mi-to-fixnum (mi-lsr (mi-sub out orig-out) 1)))) 127 | 128 | 129 | 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /utils.cl: -------------------------------------------------------------------------------- 1 | ;; -*- mode: common-lisp -*- 2 | ;; See the file LICENSE for the full license governing this code. 3 | 4 | (in-package :user) 5 | 6 | (eval-when (compile load eval) 7 | (require :defsubst)) 8 | 9 | (deftype usb8 () '(unsigned-byte 8)) 10 | (deftype sb32 () '(signed-byte 32)) 11 | (deftype usb64 () '(unsigned-byte 64)) 12 | (deftype ausb8 () '(simple-array usb8 (*))) 13 | (deftype asb32 () '(simple-array sb32 (*))) 14 | 15 | (defmacro make-ausb8 (size &rest rest) 16 | `(make-array ,size :element-type 'usb8 ,@rest)) 17 | 18 | (defconstant *sizeof-fixnum* (ff:sizeof-fobject :nat)) 19 | 20 | ;; Only works if compiled 21 | (excl::defsubst set-sb32-in-vec (value vec offset) 22 | "OFFSET must be a multiple of 4" 23 | (declare (optimize speed (safety 0)) 24 | (sb32 value) 25 | (asb32 vec) 26 | (fixnum offset)) 27 | ;; Change the division back to ash when bug22150 is fixed 28 | (setf (aref vec (/ offset 4)) value) 29 | vec) 30 | 31 | (excl::defsubst get-sb32-in-vec (vec offset) 32 | "OFFSET must be a multiple of 4" 33 | (declare (optimize speed (safety 0)) 34 | (asb32 vec) 35 | (fixnum offset)) 36 | (aref vec (ash offset -2))) 37 | 38 | ;; FIXME: Optimize 39 | (defun put-uint64-into-vec (value vec offset) 40 | (declare (optimize speed (safety 0)) 41 | (usb64 value) 42 | (ausb8 vec) 43 | (fixnum offset)) 44 | (let ((shift -64)) 45 | (declare ((integer -64 0) shift)) 46 | (dotimes (n 8) 47 | (incf shift 8) 48 | (setf (aref vec offset) (ash value shift)) 49 | (incf offset)))) 50 | 51 | ;; FIXME: Optimize 52 | (defun get-uint64-from-vec (vec offset) 53 | (declare (optimize speed (safety 0)) 54 | (ausb8 vec) 55 | (fixnum offset)) 56 | (let ((res 0)) 57 | (declare (usb64 res)) 58 | 59 | (dotimes (n 8) 60 | (setf res (logior (ash res 8) (aref vec offset))) 61 | (incf offset)) 62 | 63 | res)) 64 | 65 | ;; AABBCCDDEEFFGG -> 66 | ;; GGFFEEDDCCBBAA 67 | (defun bswap64 (value) 68 | (declare (optimize speed (safety 0)) 69 | (usb64 value)) 70 | (let ((output 0) 71 | (shift 64)) 72 | (declare (usb64 output)) 73 | (dotimes (n 8) 74 | (decf shift 8) 75 | (setf output 76 | (logior output (ash (logand value #xff) shift))) 77 | (setf value (ash value -8))) 78 | 79 | output)) 80 | 81 | #+ignore 82 | (defun test-bswap64 () 83 | (assert (= (bswap64 #x0102030405060708) #x0807060504030201)) 84 | (assert (= (bswap64 #x0807060504030201) #x0102030405060708)) 85 | t) 86 | 87 | (defun hex (value) 88 | (format t "~x~%" value)) 89 | 90 | ;; FIXME: Make a more efficient version if we detect that 91 | ;; dest-offset, src-offset and len are each a multiple of 4. 92 | (excl::defsubst copy-ausb8-into (dest dest-offset src src-offset len) 93 | (declare (optimize speed (safety 0)) 94 | (ausb8 dest src) 95 | (fixnum dest-offset src-offset len)) 96 | (dotimes (n len) 97 | (setf (aref dest dest-offset) (aref src src-offset)) 98 | (incf dest-offset) 99 | (incf src-offset)) 100 | dest) 101 | 102 | ;; Generates a hexdump of the first MAX-BYTES of FILENAME out to 103 | ;; STREAM. The hexdump is terminated with a newline if TERPRI is true. 104 | ;; The return value is undefined. 105 | (defun hexdump-file-to-stream (filename max-bytes stream terpri) 106 | (with-open-file (f filename) 107 | (let* ((buf (make-ausb8 max-bytes)) 108 | (got (read-sequence buf f))) 109 | (dotimes (n got) 110 | (format stream "~2,'0x " (aref buf n))) 111 | (when terpri 112 | (terpri stream))))) 113 | 114 | ;; Generates a hexdump of the first MAX-BYTES of FILENAME out to 115 | ;; STREAM, which defaults to *standard-output*. If STREAM is nil, a 116 | ;; string containing the hexdump will be returned. If STREAM is not 117 | ;; nil, the returned value is undefined. TERPRI is used to determine 118 | ;; whether or not a newline is added to the end of the hexdump. 119 | ;; TERPRI defaults to true unless STREAM is nil, in which case it 120 | ;; defaults to false. 121 | (defun hexdump-file (filename max-bytes &key (stream *standard-output*) 122 | (terpri t terpri-supplied-p)) 123 | (if* stream 124 | then (hexdump-file-to-stream filename max-bytes stream terpri) 125 | else (with-output-to-string (stream) 126 | (hexdump-file-to-stream filename max-bytes stream 127 | (if* terpri-supplied-p 128 | then terpri 129 | else ;; Default to no newline 130 | ;; for string output. 131 | nil))))) 132 | -------------------------------------------------------------------------------- /xdr-get-signed-int.lap: -------------------------------------------------------------------------------- 1 | (bcc :t (pc (d 839 (:reg 7 :edi :di)))) 2 | #+(version>= 9 0) (nop.w) 3 | (move.l (xl -10 (:reg 0 :eax :ax :al) (:reg 2 :edx :dx :dl)) (:reg 0 :eax :ax :al)) 4 | (bswap-eax) 5 | (clc) 6 | (move.l (d -4 (:reg 5 :ebp :bp)) (:reg 6 :esi :si)) 7 | (return) 8 | -------------------------------------------------------------------------------- /xdr-store-signed-int.lap: -------------------------------------------------------------------------------- 1 | (bcc :t (pc (d 839 (:reg 7 :edi :di)))) 2 | #+(version>= 9 0) (nop.w) 3 | (move.l (:iparam 2) (:reg 1 :ecx :cx :cl)) 4 | (bswap-eax) 5 | (move.l (:reg 0 :eax :ax :al) (xl -10 (:reg 2 :edx :dx :dl) (:reg 1 :ecx :cx :cl))) 6 | (clc) 7 | (move.l (d -4 (:reg 5 :ebp :bp)) (:reg 6 :esi :si)) 8 | (return) 9 | --------------------------------------------------------------------------------