#lang scheme (require srfi/31 "../main.ss" "../network.ss" "../errno.ss" "handle.ss") (define client-filesystem% (class* object% (filesystem<%>) (super-new) (init hostname [port-no 564] [local-hostname #f] [local-port-no #f]) (define-values (send-request flush-fid! custodian) (start-client hostname port-no local-hostname local-port-no)) (define file-executor (make-will-executor)) (parameterize ([current-custodian custodian]) (thread (rec (loop) (will-execute file-executor) (loop)))) (define/public-final (call-with-tag proc) (proc (box #f))) (define/public-final (call-with-tag+fid proc) (let ([tag (box #f)] [fid (box #f)]) (call-with-exception-handler (λ (exn) (cond [(and flush-fid! (unbox fid)) => flush-fid!]) exn) (λ () (proc tag fid))))) (define/public-final (request message) (if send-request (send-request message) (raise-9p-error ENOLINK))) (define/private (wrap-fid fid qid offset) (cond [(not (zero? (bitwise-and (qid-type qid) (type-flag dir)))) (new client-directory-handle% [fs this] [fid fid])] [else (new client-file-handle% [fs this] [fid fid] [current-offset offset])])) (define/pubment (fid->file fid qid [offset #f]) (let ([file (inner (wrap-fid fid qid offset) fid->file fid qid offset)]) (will-register file-executor file (λ (file) (send file clunk))) file)) (define/public-final (authenticate [root ""] #:user [user (or (getenv "USER") "nobody")]) (call-with-tag+fid (λ (tag fid) (match (request (make-message:t:auth tag fid user root)) [(struct message:r:auth (_ qid)) (fid->file (unbox fid) qid)] [_ (raise-9p-error EPROTO)])))) (define/public-final (attach [root ""] #:user [user (or (getenv "USER") "nobody")] #:token [auth #f]) (call-with-tag+fid (λ (tag fid) (let ([afid (if auth (send auth ->fid) #xffffffff)]) (match (request (make-message:t:attach tag fid afid user root)) [(struct message:r:attach (_ qid)) (fid->file (unbox fid) qid)] [_ (raise-9p-error EPROTO)]))))) (define/pubment (clunk) (let ([old-custodian custodian]) (when old-custodian (dynamic-wind void (λ () (inner (void) clunk)) (λ () (set!-values (send-request flush-fid! custodian) (values #f #f #f)) (custodian-shutdown-all old-custodian)))))) )) (provide client-filesystem%)