Rebuild stale transpiled lib/ artifacts to match committed source
ober
a58102063f8cc88372ca61b7f6c45b9edf31b430
--- a/lib/jerboa-fuse.sls +++ b/lib/jerboa-fuse.sls @@ -100,7 +100,7 @@ (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 #t)] + [allow-other? (get-option options 'allow-other #f)] [fd (fuse-open-device)] [mtx (make-mutex)] [ac (get-option options 'access-controller #f)] @@ -109,7 +109,12 @@ (make-condition) ac)] [uid (fuse-current-uid)] [gid (fuse-current-gid)]) - (fuse-mount! fd mountpoint fsname uid gid allow-other?) + (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? @@ -211,6 +216,8 @@ (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 @@ -306,9 +313,11 @@ (let-values ([(mode umask) (decode-mkdir-in buf off)]) (let* ([name (extract-name buf (+ off 8) limit)] [result (handler nodeid name mode ctx)]) - (if result - (encode-entry-out unique result) - (encode-error unique EIO)))) + (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)]) @@ -336,9 +345,11 @@ (extract-two-names buf (+ off 8) limit)]) (let ([result (handler nodeid oldname newdir newname ctx)]) - (if result - (encode-out-header unique 0 0) - (encode-error unique EIO))))) + (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)]) @@ -384,13 +395,16 @@ (if handler (let-values ([(fh offset size write-flags) (decode-write-in buf off)]) - (let* ([data-off (+ off 40)] - [data (make-bytevector size)]) - (bytevector-copy! buf data-off data 0 size) - (let ([written (handler nodeid fh data offset ctx)]) - (if written - (encode-write-out unique written) - (encode-error unique EIO))))) + (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)]) + (if written + (encode-write-out unique written) + (encode-error unique EIO))))))) (encode-error unique ENOSYS)))] [(= opcode FUSE-STATFS) (let ([handler (get-op ops 'statfs)]) @@ -465,35 +479,36 @@ (decode-create-in buf off)]) (let* ([name (extract-name buf (+ off 16) limit)] [result (handler nodeid name mode flags ctx)]) - (if 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) - (encode-error unique EIO)))) + (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) --- a/lib/jerboa-fuse/access.sls +++ b/lib/jerboa-fuse/access.sls @@ -17,12 +17,15 @@ (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 @@ -72,16 +75,24 @@ [else (let* ([cache (access-controller-state-cache ac)] [now (time-second (current-time))] - [expiry (eq-hashtable-ref cache pid #f)]) + [entry (eq-hashtable-ref cache pid #f)]) (cond - [(and expiry (> expiry now)) #t] + [(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? - (eq-hashtable-set! cache pid (+ now CACHE-TTL))) + (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))]) --- a/lib/jerboa-fuse/memfs.sls +++ b/lib/jerboa-fuse/memfs.sls @@ -387,18 +387,104 @@ (let* ([old-children (memfs-node-data old-parent)] [ino (hashtable-ref old-children old-name #f)]) (if ino - (let ([new-children (memfs-node-data new-parent)]) - (let ([existing (hashtable-ref - new-children - new-name - #f)]) - (when existing - (hashtable-delete! - (memfs-state-inodes fs) - existing))) - (hashtable-delete! old-children old-name) - (hashtable-set! new-children new-name ino) - #t) + (let ([src-node (get-node fs ino)] + [new-children (memfs-node-data new-parent)]) + (if (not src-node) + #f + (let ([existing (hashtable-ref + new-children + new-name + #f)]) + (if existing + (let ([dst-node (get-node fs existing)]) + (if (not dst-node) + #f + (cond + [(and (eq? (memfs-node-type + src-node) + 'dir) + (not (eq? (memfs-node-type + dst-node) + 'dir))) + #f] + [(and (not (eq? (memfs-node-type + src-node) + 'dir)) + (eq? (memfs-node-type + dst-node) + 'dir)) + #f] + [(and (eq? (memfs-node-type + dst-node) + 'dir) + (> (hashtable-size + (memfs-node-data + dst-node)) + 0)) + #f] + [else + (let ([nl (- (memfs-node-nlink + dst-node) + 1)]) + (memfs-node-nlink-set! + dst-node + nl) + (when (<= nl 0) + (hashtable-delete! + (memfs-state-inodes fs) + existing))) + (when (eq? (memfs-node-type + dst-node) + 'dir) + (memfs-node-nlink-set! + new-parent + (max 2 + (- (memfs-node-nlink + new-parent) + 1)))) + (hashtable-delete! + old-children + old-name) + (hashtable-set! + new-children + new-name + ino) + (when (eq? (memfs-node-type + src-node) + 'dir) + (memfs-node-nlink-set! + old-parent + (max 2 + (- (memfs-node-nlink + old-parent) + 1))) + (memfs-node-nlink-set! + new-parent + (+ (memfs-node-nlink + new-parent) + 1))) + #t]))) + (begin + (hashtable-delete! + old-children + old-name) + (hashtable-set! + new-children + new-name + ino) + (when (eq? (memfs-node-type src-node) + 'dir) + (memfs-node-nlink-set! + old-parent + (max 2 + (- (memfs-node-nlink + old-parent) + 1))) + (memfs-node-nlink-set! + new-parent + (+ (memfs-node-nlink new-parent) + 1))) + #t))))) #f)) #f)))) (def (make-memfs-setattr fs) --- a/lib/jerboa-fuse/vault.sls +++ b/lib/jerboa-fuse/vault.sls @@ -288,7 +288,10 @@ (quotient (- new-size 1) BLOCK-PAYLOAD))] [last-boff (if (zero? new-size) 0 - (remainder new-size BLOCK-PAYLOAD))]) + (remainder new-size BLOCK-PAYLOAD))] + [max-lidx (if (zero? old-size) + -1 + (quotient (- old-size 1) BLOCK-PAYLOAD))]) (when (and (>= last-lidx 0) (> last-boff 0)) (let ([phys (resolve-data-block vault inode last-lidx)]) (when phys @@ -305,31 +308,32 @@ phys pay)))))) (let loop ([i (+ last-lidx 1)]) - (let ([phys (resolve-data-block vault inode i)]) - (when phys - (bitmap-free! vault phys) - (if (< i DIRECT-BLOCKS) - (vector-set! - (vault-inode-direct inode) - i - VAULT-BLOCK-INVALID) - (let ([ind-blk (vault-inode-indirect inode)]) - (when (not (= ind-blk VAULT-BLOCK-INVALID)) - (let ([ind-pay (blockstore-read-block - (vault-state-bs vault) - ind-blk)]) - (when ind-pay - (let ([ptr-idx (- i DIRECT-BLOCKS)]) - (bv-set-u64le! - ind-pay - (* ptr-idx 8) - VAULT-BLOCK-INVALID) - (blockstore-write-block! - (vault-state-bs vault) - ind-blk - ind-pay))))))) - (loop (+ i 1)))))) - (vault-inode-size-set! inode new-size)] + (when (<= i max-lidx) + (let ([phys (resolve-data-block vault inode i)]) + (when phys + (bitmap-free! vault phys) + (if (< i DIRECT-BLOCKS) + (vector-set! + (vault-inode-direct inode) + i + VAULT-BLOCK-INVALID) + (let ([ind-blk (vault-inode-indirect inode)]) + (when (not (= ind-blk VAULT-BLOCK-INVALID)) + (let ([ind-pay (blockstore-read-block + (vault-state-bs vault) + ind-blk)]) + (when ind-pay + (let ([ptr-idx (- i DIRECT-BLOCKS)]) + (bv-set-u64le! + ind-pay + (* ptr-idx 8) + VAULT-BLOCK-INVALID) + (blockstore-write-block! + (vault-state-bs vault) + ind-blk + ind-pay))))))))) + (loop (+ i 1)))) + (vault-inode-size-set! inode new-size))] [else (vault-inode-size-set! inode new-size)]) (vault-inode-ctime-set! inode (time-second (current-time))) (write-inode! vault inode))) @@ -490,6 +494,7 @@ salt KDF-ITERATIONS VAULT-KEY-LEN)] + [_ (bytevector-fill! pass-bv 0)] [mk-enc (vault-encrypt-small pk master-key)] [sb-num-bv (make-bytevector 8 0)] [sb-enc (vault-encrypt-small pk sb-num-bv)] @@ -542,6 +547,7 @@ salt kdf-iter VAULT-KEY-LEN)]) + (bytevector-fill! pass-bv 0) (let ([master-key (vault-decrypt-small pk mk-enc)]) (unless master-key (bytevector-fill! pk 0) @@ -612,6 +618,7 @@ salt kdf-iter VAULT-KEY-LEN)]) + (bytevector-fill! pass-bv 0) (let ([master-key (vault-decrypt-small pk mk-enc)]) (bytevector-fill! pk 0) (unless master-key @@ -727,54 +734,68 @@ (let ([parent (read-inode vault parent-ino)]) (and parent (= (vault-inode-type parent) INODE-TYPE-DIR) - (let ([new-blk (bitmap-alloc! vault)]) - (and new-blk - (let* ([now (time-second (current-time))] - [uid (fuse-context-uid ctx)] - [gid (fuse-context-gid ctx)] - [inode (make-vault-inode new-blk INODE-TYPE-FILE - (bitwise-ior - S-IFREG - (bitwise-and mode 4095)) - uid gid 0 now now now 1 - (string->utf8 name) - (make-vector - DIRECT-BLOCKS - VAULT-BLOCK-INVALID) - VAULT-BLOCK-INVALID)]) - (write-inode! vault inode) - (dir-add! vault parent-ino parent new-blk name) - (write-inode! vault parent) - (let ([fh (alloc-fh! vault new-blk)]) - (cons (inode->fuse-entry inode) fh)))))))))) + (if (> (bytevector-length (string->utf8 name)) + VAULT-MAX-FILENAME) + (- ENAMETOOLONG) + (if (dir-lookup vault parent name) + (- EEXIST) + (let ([new-blk (bitmap-alloc! vault)]) + (and new-blk + (let* ([now (time-second (current-time))] + [uid (fuse-context-uid ctx)] + [gid (fuse-context-gid ctx)] + [inode (make-vault-inode new-blk INODE-TYPE-FILE + (bitwise-ior + S-IFREG + (bitwise-and mode 4095)) + uid gid 0 now now now 1 + (string->utf8 name) + (make-vector + DIRECT-BLOCKS + VAULT-BLOCK-INVALID) + VAULT-BLOCK-INVALID)]) + (write-inode! vault inode) + (dir-add! vault parent-ino parent + new-blk name) + (write-inode! vault parent) + (let ([fh (alloc-fh! vault new-blk)]) + (cons + (inode->fuse-entry inode) + fh)))))))))))) (def (make-vault-mkdir vault) (lambda (parent-ino name mode ctx) (with-mutex (vault-state-mutex vault) (let ([parent (read-inode vault parent-ino)]) (and parent (= (vault-inode-type parent) INODE-TYPE-DIR) - (let ([new-blk (bitmap-alloc! vault)]) - (and new-blk - (let* ([now (time-second (current-time))] - [uid (fuse-context-uid ctx)] - [gid (fuse-context-gid ctx)] - [inode (make-vault-inode new-blk INODE-TYPE-DIR - (bitwise-ior - S-IFDIR - (bitwise-and mode 4095)) - uid gid 0 now now now 2 - (string->utf8 name) - (make-vector - DIRECT-BLOCKS - VAULT-BLOCK-INVALID) - VAULT-BLOCK-INVALID)]) - (write-inode! vault inode) - (dir-add! vault parent-ino parent new-blk name) - (vault-inode-nlink-set! - parent - (+ (vault-inode-nlink parent) 1)) - (write-inode! vault parent) - (inode->fuse-entry inode))))))))) + (if (> (bytevector-length (string->utf8 name)) + VAULT-MAX-FILENAME) + (- ENAMETOOLONG) + (if (dir-lookup vault parent name) + (- EEXIST) + (let ([new-blk (bitmap-alloc! vault)]) + (and new-blk + (let* ([now (time-second (current-time))] + [uid (fuse-context-uid ctx)] + [gid (fuse-context-gid ctx)] + [inode (make-vault-inode new-blk INODE-TYPE-DIR + (bitwise-ior + S-IFDIR + (bitwise-and mode 4095)) + uid gid 0 now now now 2 + (string->utf8 name) + (make-vector + DIRECT-BLOCKS + VAULT-BLOCK-INVALID) + VAULT-BLOCK-INVALID)]) + (write-inode! vault inode) + (dir-add! vault parent-ino parent + new-blk name) + (vault-inode-nlink-set! + parent + (+ (vault-inode-nlink parent) 1)) + (write-inode! vault parent) + (inode->fuse-entry inode))))))))))) (def (make-vault-unlink vault) (lambda (parent-ino name ctx) (with-mutex (vault-state-mutex vault) @@ -832,23 +853,119 @@ (= (vault-inode-type new-parent) INODE-TYPE-DIR) (let ([child-blk (dir-lookup vault old-parent old-name)]) (and child-blk - (begin - (dir-remove! vault old-parent old-name) - (let ([existing (dir-lookup - vault - new-parent - new-name)]) - (when existing - (let ([ex-inode (read-inode - vault - existing)]) - (when ex-inode - (free-inode-blocks! vault ex-inode) - (flush-bitmap! vault))))) - (dir-add! vault new-parent-ino new-parent - child-blk new-name) - (write-inode! vault new-parent) - #t)))))))) + (let ([child-inode (read-inode vault child-blk)]) + (and child-inode + (let ([existing (dir-lookup + vault + new-parent + new-name)]) + (if existing + (let ([ex-inode (read-inode + vault + existing)]) + (and ex-inode + (cond + [(and (= (vault-inode-type + child-inode) + INODE-TYPE-DIR) + (not (= (vault-inode-type + ex-inode) + INODE-TYPE-DIR))) + #f] + [(and (not (= (vault-inode-type + child-inode) + INODE-TYPE-DIR)) + (= (vault-inode-type + ex-inode) + INODE-TYPE-DIR)) + #f] + [(and (= (vault-inode-type + ex-inode) + INODE-TYPE-DIR) + (not (dir-empty? + vault + ex-inode))) + #f] + [else + (if (> (vault-inode-nlink + ex-inode) + 1) + (vault-inode-nlink-set! + ex-inode + (- (vault-inode-nlink + ex-inode) + 1)) + (begin + (free-inode-blocks! + vault + ex-inode) + (flush-bitmap! + vault))) + (when (= (vault-inode-type + ex-inode) + INODE-TYPE-DIR) + (vault-inode-nlink-set! + new-parent + (max 2 + (- (vault-inode-nlink + new-parent) + 1)))) + (dir-remove! + vault + new-parent + new-name) + (dir-remove! + vault + old-parent + old-name) + (dir-add! vault new-parent-ino + new-parent child-blk + new-name) + (when (= (vault-inode-type + child-inode) + INODE-TYPE-DIR) + (vault-inode-nlink-set! + old-parent + (max 2 + (- (vault-inode-nlink + old-parent) + 1))) + (vault-inode-nlink-set! + new-parent + (+ (vault-inode-nlink + new-parent) + 1))) + (write-inode! + vault + old-parent) + (write-inode! + vault + new-parent) + #t]))) + (begin + (dir-remove! + vault + old-parent + old-name) + (dir-add! vault new-parent-ino + new-parent child-blk new-name) + (when (= (vault-inode-type + child-inode) + INODE-TYPE-DIR) + (vault-inode-nlink-set! + old-parent + (max 2 + (- (vault-inode-nlink + old-parent) + 1))) + (vault-inode-nlink-set! + new-parent + (+ (vault-inode-nlink + new-parent) + 1))) + (write-inode! vault old-parent) + (write-inode! vault new-parent) + #t)))))))))))) (def (make-vault-setattr vault) (lambda (ino valid fh size atime mtime ctime atimensec mtimensec ctimensec mode uid gid ctx) --- a/lib/jerboa-fuse/vault/blockstore.sls +++ b/lib/jerboa-fuse/vault/blockstore.sls @@ -206,23 +206,22 @@ (with-mutex (blockstore-state-mutex bs) (ensure-block-num 'blockstore-read-block bs block-num) (let ([sk (blockstore-state-master-key bs)]) - (and sk - (secure-key? sk) - (secure-key-live? sk) - (let* ([raw-bv (make-bytevector BLOCK-SIZE 0)] - [offset (block-offset block-num)]) - (raw-read! bs offset raw-bv) - (call-with-secure-key - sk - (lambda (mk-bv) - (let ([bk #f]) - (dynamic-wind - (lambda () (void)) - (lambda () - (set! bk (vault-block-key mk-bv block-num)) - (vault-decrypt-block bk raw-bv)) - (lambda () - (when bk (bytevector-fill! bk 0)))))))))))) + (unless (and sk (secure-key? sk) (secure-key-live? sk)) + (error 'blockstore-read-block + "no master key set (vault locked or auth failure)")) + (let* ([raw-bv (make-bytevector BLOCK-SIZE 0)] + [offset (block-offset block-num)]) + (raw-read! bs offset raw-bv) + (call-with-secure-key + sk + (lambda (mk-bv) + (let ([bk #f]) + (dynamic-wind + (lambda () (void)) + (lambda () + (set! bk (vault-block-key mk-bv block-num)) + (vault-decrypt-block bk raw-bv)) + (lambda () (when bk (bytevector-fill! bk 0))))))))))) (def (blockstore-write-block! bs block-num payload-bv) (with-mutex (blockstore-state-mutex bs) (ensure-block-num 'blockstore-write-block! bs block-num)