build: remove tracked generated .sls files and rely on src → lib transpile
ober
aca4216a7b8ba70436704e34907288e4e276a018
deleted file mode 100644 --- a/lib/jerboa-fuse.sls +++ /dev/null @@ -1,574 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/jerboa-fuse.ss - -(library (jerboa-fuse) - (export make-fuse-filesystem fuse-start! - fuse-start-background! fuse-stop! fuse-session-destroy! - fuse-session-wait fuse-session? fuse-session-fd - fuse-session-mountpoint fuse-session-mounted? - fuse-session-running? make-fuse-attr fuse-attr? - fuse-attr-ino fuse-attr-size fuse-attr-blocks - fuse-attr-atime fuse-attr-mtime fuse-attr-ctime - fuse-attr-atimensec fuse-attr-mtimensec fuse-attr-ctimensec - fuse-attr-mode fuse-attr-nlink fuse-attr-uid fuse-attr-gid - fuse-attr-rdev fuse-attr-blksize make-fuse-entry fuse-entry? - fuse-entry-nodeid fuse-entry-generation - fuse-entry-entry-valid fuse-entry-entry-valid-nsec - fuse-entry-attr-valid fuse-entry-attr-valid-nsec - fuse-entry-attr make-fuse-dirent fuse-dirent? - fuse-dirent-ino fuse-dirent-off fuse-dirent-type - fuse-dirent-name make-fuse-statfs fuse-statfs? - fuse-statfs-blocks fuse-statfs-bfree fuse-statfs-bavail - fuse-statfs-files fuse-statfs-ffree fuse-statfs-bsize - fuse-statfs-namelen fuse-statfs-frsize make-fuse-context - fuse-context? fuse-context-uid fuse-context-gid - fuse-context-pid FUSE-ROOT-ID S-IFMT S-IFDIR S-IFREG S-IFLNK - S-IFIFO S-IFCHR S-IFBLK S-IFSOCK S-IRUSR S-IWUSR S-IXUSR - S-IRGRP S-IWGRP S-IXGRP S-IROTH S-IWOTH S-IXOTH S-IRWXU - S-IRWXG S-IRWXO S-ISUID S-ISGID S-ISVTX DT-UNKNOWN DT-DIR - DT-REG DT-LNK DT-CHR DT-BLK DT-FIFO DT-SOCK O-RDONLY - O-WRONLY O-RDWR O-CREAT O-EXCL O-TRUNC O-APPEND F-OK R-OK - W-OK X-OK ENOENT EACCES EIO EEXIST ENOTDIR EISDIR EINVAL - ENOSYS ENOTEMPTY EPERM EBADF ENOMEM ENOSPC EROFS - ENAMETOOLONG ENODATA EOPNOTSUPP ENOTSUP FATTR-MODE FATTR-UID - FATTR-GID FATTR-SIZE FATTR-ATIME FATTR-MTIME FATTR-ATIME-NOW - FATTR-MTIME-NOW FATTR-CTIME FOPEN-DIRECT-IO FOPEN-KEEP-CACHE - FOPEN-NONSEEKABLE make-access-controller access-check - access-controller-lock! access-controller-unlock! - access-controller-locked? always-allowed-opcode?) - (import - (except (chezscheme) make-hash-table hash-table? sort sort! - printf fprintf format path-extension path-absolute? - with-input-from-string with-output-to-string iota \x31;+ - \x31;- partition make-date make-time meta atom?) - (jerboa prelude) (jerboa-fuse constants) (jerboa-fuse types) - (jerboa-fuse codec) (jerboa-fuse mount) - (jerboa-fuse access)) - (def (fuse-read fd buf len) (fuse-read-device fd buf len)) - (def (fuse-write fd bv) (fuse-write-device fd bv)) - (def (make-fuse-filesystem . args) - (let ([ops (make-eq-hashtable)]) - (let loop ([a args]) - (cond - [(null? a) ops] - [(null? (cdr a)) - (error 'make-fuse-filesystem "odd number of arguments")] - [else - (eq-hashtable-set! ops (car a) (cadr a)) - (loop (cddr a))])))) - (def (get-op ops key) (eq-hashtable-ref ops key #f)) - (def (fuse-start! ops mountpoint . options) - (let ([session (create-session ops mountpoint options)]) - (install-interrupt-handler session) - (run-fuse-loop session (get-option options 'debug #f)) - (cleanup-session session))) - (def (fuse-start-background! ops mountpoint . options) - (let* ([session (create-session ops mountpoint options)] - [debug? (get-option options 'debug #f)] - [thread (fork-thread - (lambda () - (run-fuse-loop session debug?) - (cleanup-session session)))]) - (fuse-session-thread-set! session thread) - session)) - (def (fuse-stop! session) - (fuse-session-running?-set! session #f)) - (def (fuse-session-destroy! session) (fuse-stop! session) - (when (>= (fuse-session-fd session) 0) - (fuse-close-device (fuse-session-fd session)) - (fuse-session-fd-set! session -1)) - (when (fuse-session-thread session) - (guard (exn [else (void)]) - (scheme-thread-join-session session))) - (when (fuse-session-mounted? session) - (guard (exn [else (void)]) - (fuse-unmount! (fuse-session-mountpoint session))) - (fuse-session-mounted?-set! session #f))) - (def (fuse-session-wait session) - (when (fuse-session-thread session) - (scheme-thread-join-session session))) - (def (scheme-thread-join-session session) - (let ([mtx (fuse-session-mutex session)] - [cv (fuse-session-done session)]) - (when cv - (with-mutex mtx - (let loop () - (when (fuse-session-running? session) - (condition-wait cv mtx) - (loop))))))) - (def (create-session ops mountpoint options) - (let* ([fsname (get-option options 'fsname "chez-fuse")] - [debug? (get-option options 'debug #f)] - [allow-other? (get-option options 'allow-other #f)] - [fd (fuse-open-device)] - [mtx (make-mutex)] - [ac (get-option options 'access-controller #f)] - [session (make-fuse-session fd mountpoint #f #f FUSE-KERNEL-VERSION - FUSE-KERNEL-MINOR-VERSION 131072 131072 ops mtx #f - (make-condition) ac)] - [uid (fuse-current-uid)] - [gid (fuse-current-gid)]) - (guard (exn - [else - (fuse-close-device fd) - (fuse-session-fd-set! session -1) - (raise exn)]) - (fuse-mount! fd mountpoint fsname uid gid allow-other?)) - (fuse-session-mounted?-set! session #t) - (fuse-session-running?-set! session #t) - (when debug? - (printf - "chez-fuse: mounted ~a at ~a (fd=~a)\n" - fsname - mountpoint - fd)) - session)) - (def (cleanup-session session) - (let ([mountpoint (fuse-session-mountpoint session)] - [fd (fuse-session-fd session)]) - (when (and (fuse-session-mounted? session) (>= fd 0)) - (fuse-close-device fd) - (fuse-session-fd-set! session -1) - (guard (exn [else (void)]) (fuse-unmount! mountpoint)) - (fuse-session-mounted?-set! session #f)) - (fuse-session-running?-set! session #f) - (let ([cv (fuse-session-done session)]) - (when cv (condition-broadcast cv))))) - (def (install-interrupt-handler session) - (keyboard-interrupt-handler - (lambda () (fuse-stop! session)))) - (def (run-fuse-loop session debug?) - (let ([buf (make-bytevector FUSE-MAX-BUFFER-SIZE)] - [fd (fuse-session-fd session)]) - (let loop () - (when (fuse-session-running? session) - (let ([n (fuse-read fd buf FUSE-MAX-BUFFER-SIZE)]) - (cond - [(> n 0) (handle-request session buf n debug?) (loop)] - [else - (when debug? - (printf - "chez-fuse: read returned ~a, stopping\n" - n))])))))) - (def (always-allowed-opcode? op) - (or (= op FUSE-INIT) - (= op FUSE-DESTROY) - (= op FUSE-INTERRUPT))) - (def (stealth-deny-response opcode unique nodeid) - (cond - [(and (= opcode FUSE-GETATTR) (= nodeid FUSE-ROOT-ID)) - (encode-attr-out unique 1 0 (stealth-deny-attr))] - [(and (= opcode FUSE-READDIR) (= nodeid FUSE-ROOT-ID)) - (encode-dirents - unique - (stealth-deny-readdir FUSE-ROOT-ID) - 4096)] - [(and (= opcode FUSE-ACCESS) (= nodeid FUSE-ROOT-ID)) - (encode-out-header unique 0 0)] - [(and (= opcode FUSE-OPENDIR) (= nodeid FUSE-ROOT-ID)) - (encode-open-out unique 0 0)] - [(= opcode FUSE-STATFS) - (encode-statfs-out unique (stealth-deny-statfs))] - [(= opcode FUSE-RELEASEDIR) (encode-out-header unique 0 0)] - [(or (= opcode FUSE-FORGET) (= opcode FUSE-BATCH-FORGET)) - #f] - [(= opcode FUSE-LOOKUP) (encode-error unique ENOENT)] - [else (encode-error unique ENOENT)])) - (def (handle-request session buf n debug?) - (let* ([hdr (decode-in-header buf)] - [opcode (fuse-request-opcode hdr)] - [unique (fuse-request-unique hdr)] - [nodeid (fuse-request-nodeid hdr)] - [uid (fuse-request-uid hdr)] - [gid (fuse-request-gid hdr)] - [pid (fuse-request-pid hdr)] - [ctx (make-fuse-context uid gid pid)] - [ops (fuse-session-ops session)] - [fd (fuse-session-fd session)] - [mtx (fuse-session-mutex session)] - [ac (fuse-session-access session)] - [payload-off FUSE-IN-HEADER-SIZE]) - (when debug? - (printf "chez-fuse: op=~a unique=~a node=~a pid=~a\n" - (opcode->name opcode) unique nodeid pid)) - (let ([response (if (and ac - (not (always-allowed-opcode? opcode)) - (not (access-check ac pid))) - (begin - (when debug? - (printf - "chez-fuse: DENIED pid=~a op=~a (stealth)\n" - pid - (opcode->name opcode))) - (stealth-deny-response - opcode - unique - nodeid)) - (guard (exn - [else - (when debug? - (printf - "chez-fuse: handler error op=~a: ~a\n" - opcode - (exn-message exn))) - (encode-error unique EIO)]) - (with-mutex mtx - (dispatch-opcode session ops opcode unique - nodeid ctx buf payload-off n))))]) - (when (and response (>= fd 0)) (fuse-write fd response))))) - (def (handler-error-code result) - (and (integer? result) (negative? result) (- result))) - (def (dispatch-opcode session ops opcode unique nodeid ctx - buf off limit) - (cond - [(= opcode FUSE-INIT) - (let-values ([(major minor max-readahead flags) - (decode-init-in buf off)]) - (fuse-session-proto-major-set! session major) - (fuse-session-proto-minor-set! session minor) - (fuse-session-max-readahead-set! - session - (min max-readahead (fuse-session-max-readahead session))) - (let ([init-handler (get-op ops 'init)]) - (when init-handler (init-handler))) - (encode-init-out unique FUSE-KERNEL-VERSION FUSE-KERNEL-MINOR-VERSION - (fuse-session-max-readahead session) 0 - (fuse-session-max-write session)))] - [(= opcode FUSE-DESTROY) - (let ([handler (get-op ops 'destroy)]) - (when handler (handler))) - (fuse-session-running?-set! session #f) - (encode-out-header unique 0 0)] - [(= opcode FUSE-LOOKUP) - (let ([handler (get-op ops 'lookup)]) - (if handler - (let* ([name (extract-name buf off limit)] - [result (handler nodeid name ctx)]) - (if result - (encode-entry-out unique result) - (encode-error unique ENOENT))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-FORGET) - (let ([handler (get-op ops 'forget)]) - (when handler (handler nodeid (decode-forget-in buf off)))) - #f] - [(= opcode FUSE-BATCH-FORGET) - (let ([handler (get-op ops 'forget)]) - (when handler - (for-each - (lambda (p) (handler (car p) (cdr p))) - (decode-batch-forget-in buf off)))) - #f] - [(= opcode FUSE-GETATTR) - (let ([handler (get-op ops 'getattr)]) - (if handler - (let ([result (handler nodeid ctx)]) - (if result - (encode-attr-out unique 1 0 result) - (encode-error unique ENOENT))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-SETATTR) - (let ([handler (get-op ops 'setattr)]) - (if handler - (let-values ([(valid fh size atime mtime ctime atimensec mtimensec ctimensec mode uid gid) - (decode-setattr-in buf off)]) - (let ([result (handler nodeid valid fh size atime mtime ctime - atimensec mtimensec ctimensec mode uid - gid ctx)]) - (cond - [(handler-error-code result) => - (lambda (e) (encode-error unique e))] - [result (encode-attr-out unique 1 0 result)] - [else (encode-error unique EIO)]))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-READLINK) - (let ([handler (get-op ops 'readlink)]) - (if handler - (let ([target (handler nodeid ctx)]) - (if target - (encode-readlink-out unique target) - (encode-error unique ENOENT))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-SYMLINK) - (let ([handler (get-op ops 'symlink)]) - (if handler - (let-values ([(name target) - (extract-two-names buf off limit)]) - (let ([result (handler nodeid name target ctx)]) - (if result - (encode-entry-out unique result) - (encode-error unique EIO)))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-MKNOD) - (let ([handler (get-op ops 'mknod)]) - (if handler - (let-values ([(mode rdev umask) (decode-mknod-in buf off)]) - (let* ([name (extract-name buf (+ off 16) limit)] - [result (handler nodeid name mode rdev ctx)]) - (if result - (encode-entry-out unique result) - (encode-error unique EIO)))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-MKDIR) - (let ([handler (get-op ops 'mkdir)]) - (if handler - (let-values ([(mode umask) (decode-mkdir-in buf off)]) - (let* ([name (extract-name buf (+ off 8) limit)] - [result (handler nodeid name mode ctx)]) - (cond - [(handler-error-code result) => - (lambda (e) (encode-error unique e))] - [result (encode-entry-out unique result)] - [else (encode-error unique EIO)]))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-UNLINK) - (let ([handler (get-op ops 'unlink)]) - (if handler - (let* ([name (extract-name buf off limit)] - [result (handler nodeid name ctx)]) - (if result - (encode-out-header unique 0 0) - (encode-error unique EIO))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-RMDIR) - (let ([handler (get-op ops 'rmdir)]) - (if handler - (let* ([name (extract-name buf off limit)] - [result (handler nodeid name ctx)]) - (if result - (encode-out-header unique 0 0) - (encode-error unique EIO))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-RENAME) - (let ([handler (get-op ops 'rename)]) - (if handler - (let ([newdir (decode-rename-in buf off)]) - (let-values ([(oldname newname) - (extract-two-names buf (+ off 8) limit)]) - (let ([result (handler nodeid oldname newdir newname - ctx)]) - (cond - [(handler-error-code result) => - (lambda (e) (encode-error unique e))] - [result (encode-out-header unique 0 0)] - [else (encode-error unique EIO)])))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-LINK) - (let ([handler (get-op ops 'link)]) - (if handler - (let* ([oldnodeid (decode-link-in buf off)] - [name (extract-name buf (+ off 8) limit)] - [result (handler nodeid name oldnodeid ctx)]) - (if result - (encode-entry-out unique result) - (encode-error unique EIO))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-OPEN) - (let ([handler (get-op ops 'open)]) - (if handler - (let-values ([(flags open-flags) (decode-open-in buf off)]) - (let ([result (handler nodeid flags ctx)]) - (cond - [(not result) (encode-error unique EACCES)] - [(pair? result) - (encode-open-out unique (car result) (cdr result))] - [else (encode-open-out unique result 0)]))) - (encode-open-out unique 0 0)))] - [(= opcode FUSE-READ) - (let ([handler (get-op ops 'read)]) - (if handler - (let-values ([(fh offset size read-flags) - (decode-read-in buf off)]) - (let ([data (handler nodeid fh size offset ctx)]) - (cond - [(handler-error-code data) => - (lambda (e) (encode-error unique e))] - [data - (let* ([dlen (bytevector-length data)] - [total (+ FUSE-OUT-HEADER-SIZE dlen)] - [resp (make-bytevector total 0)]) - (bytevector-u32-native-set! resp 0 total) - (bytevector-s32-native-set! resp 4 0) - (bytevector-u64-native-set! resp 8 unique) - (bytevector-copy! data 0 resp FUSE-OUT-HEADER-SIZE - dlen) - resp)] - [else (encode-error unique EIO)]))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-WRITE) - (let ([handler (get-op ops 'write)]) - (if handler - (let-values ([(fh offset size write-flags) - (decode-write-in buf off)]) - (let* ([data-off (+ off 40)]) - (if (> (+ data-off size) limit) - (encode-error unique EINVAL) - (let ([data (make-bytevector size)]) - (bytevector-copy! buf data-off data 0 size) - (let ([written (handler nodeid fh data offset - ctx)]) - (cond - [(handler-error-code written) => - (lambda (e) (encode-error unique e))] - [written (encode-write-out unique written)] - [else (encode-error unique EIO)])))))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-STATFS) - (let ([handler (get-op ops 'statfs)]) - (let ([st (if handler - (handler ctx) - (make-fuse-statfs 0 0 0 0 0 4096 255 4096))]) - (encode-statfs-out - unique - (or st (make-fuse-statfs 0 0 0 0 0 4096 255 4096)))))] - [(= opcode FUSE-RELEASE) - (let ([handler (get-op ops 'release)]) - (when handler - (let-values ([(fh flags) (decode-release-in buf off)]) - (handler nodeid fh ctx))) - (encode-out-header unique 0 0))] - [(= opcode FUSE-FLUSH) - (let ([handler (get-op ops 'flush)]) - (when handler - (let-values ([(fh lock-owner) (decode-flush-in buf off)]) - (handler nodeid fh ctx))) - (encode-out-header unique 0 0))] - [(= opcode FUSE-FSYNC) - (let ([handler (get-op ops 'fsync)]) - (when handler - (let-values ([(fh fsync-flags) (decode-fsync-in buf off)]) - (handler - nodeid - fh - (not (zero? (bitwise-and fsync-flags 1))) - ctx))) - (encode-out-header unique 0 0))] - [(= opcode FUSE-OPENDIR) - (let ([handler (get-op ops 'opendir)]) - (if handler - (let-values ([(flags open-flags) (decode-open-in buf off)]) - (let ([result (handler nodeid flags ctx)]) - (cond - [(not result) (encode-error unique EACCES)] - [(pair? result) - (encode-open-out unique (car result) (cdr result))] - [else (encode-open-out unique result 0)]))) - (encode-open-out unique 0 0)))] - [(= opcode FUSE-READDIR) - (let ([handler (get-op ops 'readdir)]) - (if handler - (let-values ([(fh offset size read-flags) - (decode-read-in buf off)]) - (let ([dirents (handler nodeid fh offset ctx)]) - (if (and dirents (not (null? dirents))) - (encode-dirents unique dirents size) - (encode-out-header unique 0 0)))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-RELEASEDIR) - (let ([handler (get-op ops 'releasedir)]) - (when handler - (let-values ([(fh flags) (decode-release-in buf off)]) - (handler nodeid fh ctx))) - (encode-out-header unique 0 0))] - [(= opcode FUSE-FSYNCDIR) (encode-out-header unique 0 0)] - [(= opcode FUSE-ACCESS) - (let ([handler (get-op ops 'access)]) - (if handler - (let ([mask (decode-access-in buf off)]) - (if (handler nodeid mask ctx) - (encode-out-header unique 0 0) - (encode-error unique EACCES))) - (encode-out-header unique 0 0)))] - [(= opcode FUSE-CREATE) - (let ([handler (get-op ops 'create)]) - (if handler - (let-values ([(flags mode umask open-flags) - (decode-create-in buf off)]) - (let* ([name (extract-name buf (+ off 16) limit)] - [result (handler nodeid name mode flags ctx)]) - (cond - [(handler-error-code result) => - (lambda (e) (encode-error unique e))] - [result - (let* ([entry (car result)] - [fh-part (cdr result)] - [fh (if (pair? fh-part) - (car fh-part) - fh-part)] - [oflags (if (pair? fh-part) (cdr fh-part) 0)] - [total (+ FUSE-OUT-HEADER-SIZE - FUSE-ENTRY-OUT-SIZE - FUSE-OPEN-OUT-SIZE)] - [resp (make-bytevector total 0)] - [entry-bv (encode-entry-out unique entry)]) - (bytevector-u32-native-set! resp 0 total) - (bytevector-s32-native-set! resp 4 0) - (bytevector-u64-native-set! resp 8 unique) - (bytevector-copy! entry-bv FUSE-OUT-HEADER-SIZE resp - FUSE-OUT-HEADER-SIZE FUSE-ENTRY-OUT-SIZE) - (bytevector-u64-native-set! - resp - (+ FUSE-OUT-HEADER-SIZE FUSE-ENTRY-OUT-SIZE) - fh) - (bytevector-u32-native-set! - resp - (+ FUSE-OUT-HEADER-SIZE FUSE-ENTRY-OUT-SIZE 8) - oflags) - resp)] - [else (encode-error unique EIO)]))) - (encode-error unique ENOSYS)))] - [(= opcode FUSE-INTERRUPT) #f] - [(= opcode FUSE-LSEEK) - (let ([handler (get-op ops 'lseek)]) - (if handler - (let-values ([(fh offset whence) - (decode-lseek-in buf off)]) - (let ([result (handler nodeid fh offset whence ctx)]) - (if result - (encode-lseek-out unique result) - (encode-error unique ENOSYS)))) - (encode-error unique ENOSYS)))] - [else (encode-error unique ENOSYS)])) - (def (get-option options key default) - (let loop ([opts options]) - (cond - [(null? opts) default] - [(null? (cdr opts)) default] - [(eq? (car opts) key) (cadr opts)] - [else (loop (cddr opts))]))) - (def (opcode->name op) - (cond - [(= op FUSE-LOOKUP) "LOOKUP"] - [(= op FUSE-FORGET) "FORGET"] - [(= op FUSE-GETATTR) "GETATTR"] - [(= op FUSE-SETATTR) "SETATTR"] - [(= op FUSE-READLINK) "READLINK"] - [(= op FUSE-SYMLINK) "SYMLINK"] - [(= op FUSE-MKNOD) "MKNOD"] - [(= op FUSE-MKDIR) "MKDIR"] - [(= op FUSE-UNLINK) "UNLINK"] - [(= op FUSE-RMDIR) "RMDIR"] - [(= op FUSE-RENAME) "RENAME"] - [(= op FUSE-LINK) "LINK"] - [(= op FUSE-OPEN) "OPEN"] - [(= op FUSE-READ) "READ"] - [(= op FUSE-WRITE) "WRITE"] - [(= op FUSE-STATFS) "STATFS"] - [(= op FUSE-RELEASE) "RELEASE"] - [(= op FUSE-FLUSH) "FLUSH"] - [(= op FUSE-FSYNC) "FSYNC"] - [(= op FUSE-INIT) "INIT"] - [(= op FUSE-OPENDIR) "OPENDIR"] - [(= op FUSE-READDIR) "READDIR"] - [(= op FUSE-RELEASEDIR) "RELEASEDIR"] - [(= op FUSE-ACCESS) "ACCESS"] - [(= op FUSE-CREATE) "CREATE"] - [(= op FUSE-DESTROY) "DESTROY"] - [(= op FUSE-INTERRUPT) "INTERRUPT"] - [(= op FUSE-BATCH-FORGET) "BATCH_FORGET"] - [else (number->string op)])) - (def (exn-message c) - (if (message-condition? c) - (condition-message c) - "unknown error"))) deleted file mode 100644 --- a/lib/jerboa-fuse/access.sls +++ /dev/null @@ -1,106 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/jerboa-fuse/access.ss - -(library (jerboa-fuse access) - (export make-access-controller access-check access-controller-lock! - access-controller-unlock! access-controller-locked? - stealth-deny-attr stealth-deny-readdir stealth-deny-statfs - access-current-pid pid-is-descendant?) - (import - (except (chezscheme) make-hash-table hash-table? sort sort! - printf fprintf format path-extension path-absolute? - with-input-from-string with-output-to-string iota \x31;+ - \x31;- partition make-date make-time meta atom?) - (except (jerboa prelude) c-lambda) - (only (jerboa ffi) c-lambda) (jerboa-fuse constants) - (jerboa-fuse types) (jerboa-fuse mount)) - (def c-getpid #f) - (def c-getppid-of #f) - (def c-get-start-time #f) - (def *bindings-ready?* #f) - (def (ensure-access-bindings!) - (when (and (ensure-mount-lib!) (not *bindings-ready?*)) - (set! c-getpid (c-lambda () int "jerboa_fuse_getpid")) - (set! c-getppid-of - (c-lambda (int) int "jerboa_fuse_getppid_of")) - (set! c-get-start-time - (c-lambda (int) integer-64 "jerboa_fuse_get_start_time")) - (set! *bindings-ready?* #t)) - (unless *bindings-ready?* - (error 'jerboa-fuse/access - "unable to load native process helpers"))) - (def (access-current-pid) - (ensure-access-bindings!) - (c-getpid)) - (def (pid-is-descendant? pid ancestor-pid) - (ensure-access-bindings!) - (let loop ([current pid] [depth 0]) - (cond - [(= current ancestor-pid) #t] - [(<= current 1) #f] - [(> depth 64) #f] - [else - (let ([ppid (c-getppid-of current)]) - (if (< ppid 0) #f (loop ppid (+ depth 1))))]))) - (def CACHE-TTL 5) - (define-record-type access-controller-state - (fields - (immutable owner-pid) - (mutable locked?) - (mutable cache) - (mutable mutex))) - (def (make-access-controller) - (make-access-controller-state - (access-current-pid) - #f - (make-eq-hashtable) - (make-mutex))) - (def (access-controller-locked? ac) - (access-controller-state-locked? ac)) - (def (access-controller-lock! ac) - (with-mutex (access-controller-state-mutex ac) - (access-controller-state-locked?-set! ac #t) - (access-controller-state-cache-set! - ac - (make-eq-hashtable)))) - (def (access-controller-unlock! ac) - (with-mutex (access-controller-state-mutex ac) - (access-controller-state-locked?-set! ac #f))) - (def (access-check ac pid) - (with-mutex (access-controller-state-mutex ac) - (cond - [(access-controller-state-locked? ac) #f] - [(= pid (access-controller-state-owner-pid ac)) #t] - [else - (let* ([cache (access-controller-state-cache ac)] - [now (time-second (current-time))] - [entry (eq-hashtable-ref cache pid #f)]) - (cond - [(and entry - (> (cdr entry) now) - (let ([st (c-get-start-time pid)]) - (and (>= st 0) (= st (car entry))))) - #t] - [else - (let ([trusted? (pid-is-descendant? - pid - (access-controller-state-owner-pid - ac))]) - (when trusted? - (let ([st (c-get-start-time pid)]) - (eq-hashtable-set! - cache - pid - (cons st (+ now CACHE-TTL))))) - trusted?)]))]))) - (def (stealth-deny-attr) - (let ([now (time-second (current-time))]) - (make-fuse-attr FUSE-ROOT-ID 0 0 now now now 0 0 0 - (bitwise-ior S-IFDIR 493) 2 0 0 0 4096))) - (def (stealth-deny-readdir ino) - (list - (make-fuse-dirent ino 1 DT-DIR ".") - (make-fuse-dirent ino 2 DT-DIR ".."))) - (def (stealth-deny-statfs) - (make-fuse-statfs 0 0 0 0 0 4096 255 4096))) deleted file mode 100644 --- a/lib/jerboa-fuse/codec.sls +++ /dev/null @@ -1,322 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/jerboa-fuse/codec.ss - -(library (jerboa-fuse codec) - (export decode-in-header decode-init-in decode-getattr-in - decode-setattr-in decode-open-in decode-read-in - decode-write-in decode-release-in decode-flush-in - decode-fsync-in decode-mkdir-in decode-mknod-in - decode-rename-in decode-link-in decode-create-in - decode-access-in decode-forget-in decode-batch-forget-in - decode-interrupt-in decode-lseek-in decode-fallocate-in - extract-name extract-two-names encode-out-header - encode-error encode-attr-out encode-entry-out - encode-open-out encode-write-out encode-statfs-out - encode-init-out encode-lseek-out encode-readlink-out - encode-dirent encode-dirents FUSE-ATTR-SIZE - FUSE-ENTRY-OUT-SIZE FUSE-ATTR-OUT-SIZE FUSE-OPEN-OUT-SIZE - FUSE-WRITE-OUT-SIZE FUSE-STATFS-OUT-SIZE FUSE-INIT-OUT-SIZE - FUSE-DIRENT-HEADER-SIZE) - (import - (except (chezscheme) make-hash-table hash-table? sort sort! - printf fprintf format path-extension path-absolute? - with-input-from-string with-output-to-string iota \x31;+ - \x31;- partition make-date make-time meta atom?) - (jerboa prelude) - (jerboa-fuse constants) - (jerboa-fuse types)) - (def FUSE-ATTR-SIZE 88) - (def FUSE-ENTRY-OUT-SIZE 128) - (def FUSE-ATTR-OUT-SIZE 104) - (def FUSE-OPEN-OUT-SIZE 16) - (def FUSE-WRITE-OUT-SIZE 8) - (def FUSE-STATFS-OUT-SIZE 80) - (def FUSE-INIT-OUT-SIZE 64) - (def FUSE-DIRENT-HEADER-SIZE 24) - (def FUSE-LSEEK-OUT-SIZE 8) - (def (u32-ref bv off) (bytevector-u32-native-ref bv off)) - (def (u64-ref bv off) (bytevector-u64-native-ref bv off)) - (def (s32-ref bv off) (bytevector-s32-native-ref bv off)) - (def (u32-set! bv off v) - (bytevector-u32-native-set! bv off v)) - (def (u64-set! bv off v) - (bytevector-u64-native-set! bv off v)) - (def (s32-set! bv off v) - (bytevector-s32-native-set! bv off v)) - (def (u16-set! bv off v) - (bytevector-u16-native-set! bv off v)) - (def (decode-in-header buf) - (make-fuse-request (u32-ref buf 0) (u32-ref buf 4) (u64-ref buf 8) - (u64-ref buf 16) (u32-ref buf 24) (u32-ref buf 28) - (u32-ref buf 32))) - (def (decode-init-in buf off) - (values - (u32-ref buf off) - (u32-ref buf (+ off 4)) - (u32-ref buf (+ off 8)) - (u32-ref buf (+ off 12)))) - (def (decode-getattr-in buf off) - (values (u32-ref buf off) (u64-ref buf (+ off 8)))) - (def (decode-setattr-in buf off) - (values (u32-ref buf off) (u64-ref buf (+ off 8)) - (u64-ref buf (+ off 16)) (u64-ref buf (+ off 32)) - (u64-ref buf (+ off 40)) (u64-ref buf (+ off 48)) - (u32-ref buf (+ off 56)) (u32-ref buf (+ off 60)) - (u32-ref buf (+ off 64)) (u32-ref buf (+ off 68)) - (u32-ref buf (+ off 76)) (u32-ref buf (+ off 80)))) - (def (decode-open-in buf off) - (values (u32-ref buf off) (u32-ref buf (+ off 4)))) - (def (decode-read-in buf off) - (values - (u64-ref buf off) - (u64-ref buf (+ off 8)) - (u32-ref buf (+ off 16)) - (u32-ref buf (+ off 20)))) - (def (decode-write-in buf off) - (values - (u64-ref buf off) - (u64-ref buf (+ off 8)) - (u32-ref buf (+ off 16)) - (u32-ref buf (+ off 20)))) - (def (decode-release-in buf off) - (values (u64-ref buf off) (u32-ref buf (+ off 8)))) - (def (decode-flush-in buf off) - (values (u64-ref buf off) (u64-ref buf (+ off 16)))) - (def (decode-fsync-in buf off) - (values (u64-ref buf off) (u32-ref buf (+ off 8)))) - (def (decode-mkdir-in buf off) - (values (u32-ref buf off) (u32-ref buf (+ off 4)))) - (def (decode-mknod-in buf off) - (values - (u32-ref buf off) - (u32-ref buf (+ off 4)) - (u32-ref buf (+ off 8)))) - (def (decode-rename-in buf off) (u64-ref buf off)) - (def (decode-link-in buf off) (u64-ref buf off)) - (def (decode-create-in buf off) - (values - (u32-ref buf off) - (u32-ref buf (+ off 4)) - (u32-ref buf (+ off 8)) - (u32-ref buf (+ off 12)))) - (def (decode-access-in buf off) (u32-ref buf off)) - (def (decode-forget-in buf off) (u64-ref buf off)) - (def (decode-batch-forget-in buf off) - (let ([count (u32-ref buf off)]) - (let loop ([i 0] [pos (+ off 8)] [acc '()]) - (if (= i count) - (reverse acc) - (loop - (+ i 1) - (+ pos 16) - (cons - (cons (u64-ref buf pos) (u64-ref buf (+ pos 8))) - acc)))))) - (def (decode-interrupt-in buf off) (u64-ref buf off)) - (def (decode-lseek-in buf off) - (values - (u64-ref buf off) - (u64-ref buf (+ off 8)) - (u32-ref buf (+ off 16)))) - (def (decode-fallocate-in buf off) - (values - (u64-ref buf off) - (u64-ref buf (+ off 8)) - (u64-ref buf (+ off 16)) - (u32-ref buf (+ off 24)))) - (def (extract-name buf off limit) - (let loop ([end off]) - (cond - [(>= end limit) (utf8->string (bv-slice buf off end))] - [(= (bytevector-u8-ref buf end) 0) - (utf8->string (bv-slice buf off end))] - [else (loop (+ end 1))]))) - (def (extract-two-names buf off limit) - (let ([name1-end (let loop ([i off]) - (cond - [(>= i limit) i] - [(= (bytevector-u8-ref buf i) 0) i] - [else (loop (+ i 1))]))]) - (let ([name1 (utf8->string (bv-slice buf off name1-end))] - [name2-start (+ name1-end 1)]) - (let ([name2 (extract-name buf name2-start limit)]) - (values name1 name2))))) - (def (bv-slice bv start end) - (let* ([len (- end start)] [result (make-bytevector len)]) - (bytevector-copy! bv start result 0 len) - result)) - (def (encode-out-header unique error payload-size) - (let ([bv (make-bytevector FUSE-OUT-HEADER-SIZE 0)]) - (u32-set! bv 0 (+ FUSE-OUT-HEADER-SIZE payload-size)) - (s32-set! bv 4 error) - (u64-set! bv 8 unique) - bv)) - (def (encode-error unique errno-val) - (encode-out-header unique (- errno-val) 0)) - (def (encode-attr! bv off attr) - (u64-set! bv off (fuse-attr-ino attr)) - (u64-set! bv (+ off 8) (fuse-attr-size attr)) - (u64-set! bv (+ off 16) (fuse-attr-blocks attr)) - (u64-set! bv (+ off 24) (fuse-attr-atime attr)) - (u64-set! bv (+ off 32) (fuse-attr-mtime attr)) - (u64-set! bv (+ off 40) (fuse-attr-ctime attr)) - (u32-set! bv (+ off 48) (fuse-attr-atimensec attr)) - (u32-set! bv (+ off 52) (fuse-attr-mtimensec attr)) - (u32-set! bv (+ off 56) (fuse-attr-ctimensec attr)) - (u32-set! bv (+ off 60) (fuse-attr-mode attr)) - (u32-set! bv (+ off 64) (fuse-attr-nlink attr)) - (u32-set! bv (+ off 68) (fuse-attr-uid attr)) - (u32-set! bv (+ off 72) (fuse-attr-gid attr)) - (u32-set! bv (+ off 76) (fuse-attr-rdev attr)) - (u32-set! bv (+ off 80) (fuse-attr-blksize attr)) - (u32-set! bv (+ off 84) 0)) - (def (encode-attr-out - unique - attr-valid - attr-valid-nsec - attr) - (let* ([payload-size FUSE-ATTR-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u64-set! bv 16 attr-valid) - (u32-set! bv 24 attr-valid-nsec) - (encode-attr! bv 32 attr) - bv)) - (def (encode-entry-out unique entry) - (let* ([payload-size FUSE-ENTRY-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u64-set! bv 16 (fuse-entry-nodeid entry)) - (u64-set! bv 24 (fuse-entry-generation entry)) - (u64-set! bv 32 (fuse-entry-entry-valid entry)) - (u64-set! bv 40 (fuse-entry-attr-valid entry)) - (u32-set! bv 48 (fuse-entry-entry-valid-nsec entry)) - (u32-set! bv 52 (fuse-entry-attr-valid-nsec entry)) - (encode-attr! bv 56 (fuse-entry-attr entry)) - bv)) - (def (encode-open-out unique fh open-flags) - (let* ([payload-size FUSE-OPEN-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u64-set! bv 16 fh) - (u32-set! bv 24 open-flags) - bv)) - (def (encode-write-out unique size) - (let* ([payload-size FUSE-WRITE-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u32-set! bv 16 size) - bv)) - (def (encode-statfs-out unique st) - (let* ([payload-size FUSE-STATFS-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u64-set! bv 16 (fuse-statfs-blocks st)) - (u64-set! bv 24 (fuse-statfs-bfree st)) - (u64-set! bv 32 (fuse-statfs-bavail st)) - (u64-set! bv 40 (fuse-statfs-files st)) - (u64-set! bv 48 (fuse-statfs-ffree st)) - (u32-set! bv 56 (fuse-statfs-bsize st)) - (u32-set! bv 60 (fuse-statfs-namelen st)) - (u32-set! bv 64 (fuse-statfs-frsize st)) - bv)) - (def (encode-init-out unique major minor max-readahead flags - max-write) - (let* ([payload-size FUSE-INIT-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u32-set! bv 16 major) - (u32-set! bv 20 minor) - (u32-set! bv 24 max-readahead) - (u32-set! bv 28 flags) - (u16-set! bv 32 32) - (u16-set! bv 34 24) - (u32-set! bv 36 max-write) - (u32-set! bv 40 1) - bv)) - (def (encode-lseek-out unique offset) - (let* ([payload-size FUSE-LSEEK-OUT-SIZE] - [total (+ FUSE-OUT-HEADER-SIZE payload-size)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (u64-set! bv 16 offset) - bv)) - (def (encode-readlink-out unique target) - (let* ([data (string->utf8 target)] - [total (+ FUSE-OUT-HEADER-SIZE (bytevector-length data))] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (bytevector-copy! data 0 bv FUSE-OUT-HEADER-SIZE - (bytevector-length data)) - bv)) - (def (encode-dirent dirent) - (let* ([name-bv (string->utf8 (fuse-dirent-name dirent))] - [namelen (bytevector-length name-bv)] - [reclen (fuse-rec-align - (+ FUSE-DIRENT-HEADER-SIZE namelen))] - [bv (make-bytevector reclen 0)]) - (u64-set! bv 0 (fuse-dirent-ino dirent)) - (u64-set! bv 8 (fuse-dirent-off dirent)) - (u32-set! bv 16 namelen) - (u32-set! bv 20 (fuse-dirent-type dirent)) - (bytevector-copy! name-bv 0 bv 24 namelen) - bv)) - (def (encode-dirents unique dirents max-size) - (let measure ([ds dirents] [items '()] [total-payload 0]) - (if (null? ds) - (build-dirents unique (reverse items) total-payload) - (let* ([d (car ds)] - [name-bv (string->utf8 (fuse-dirent-name d))] - [reclen (fuse-rec-align - (+ FUSE-DIRENT-HEADER-SIZE - (bytevector-length name-bv)))] - [new-total (+ total-payload reclen)]) - (if (> new-total max-size) - (build-dirents unique (reverse items) total-payload) - (measure - (cdr ds) - (cons (vector d name-bv reclen) items) - new-total)))))) - (def (build-dirents unique items total-payload) - (let* ([total (+ FUSE-OUT-HEADER-SIZE total-payload)] - [bv (make-bytevector total 0)]) - (u32-set! bv 0 total) - (s32-set! bv 4 0) - (u64-set! bv 8 unique) - (let loop ([is items] [pos FUSE-OUT-HEADER-SIZE]) - (unless (null? is) - (let* ([item (car is)] - [d (vector-ref item 0)] - [name-bv (vector-ref item 1)]