#lang scheme
(require
scheme/generator
"../main.ss"
"../network/message.ss"
"../errno.ss"
"handle.ss")
(define server-file/stat<%>
(interface (server-file<%>)
on-name-change name content-length touch truncate))
(define server-file:stat-mixin
(mixin (server-file<%>) (server-file/stat<%>)
(super-new)
(init-field current-name mode
[uid (or (getenv "USER") "nobody")] [gid uid] [muid uid]
[mtime (current-seconds)] [atime mtime]
[type 0] [dev 0] [version 0] [path (eq-hash-code this)])
(define name-change-listeners
null)
(define/public-final (on-name-change key listener)
(set! name-change-listeners
(if listener
(dict-set name-change-listeners key listener)
(dict-remove name-change-listeners key))))
(define/public-final name
(case-lambda
[()
(or current-name (raise-9p-error ENOENT))]
[(new-name)
(for ([listener (in-dict-values name-change-listeners)])
(listener current-name new-name))
(set! current-name new-name)]))
(define/public (content-length context)
0)
(define/public-final (touch context modified? [time (current-seconds)])
(set! atime time)
(when modified?
(set! mtime time)
(set! muid (send context ->user))))
(define/pubment (truncate context [time (current-seconds)])
(inner (raise-9p-error EINVAL) truncate context time)
(touch context #t time))
(define/override-final (read-stat context)
(let ([mode (file-mode (if (is-a? this server-directory%)
(file-type dir)
(file-type file))
mode)])
(make-stat type dev (make-qid (file-mode-type mode) version path) mode
atime mtime (content-length context) current-name uid gid muid)))
(define/override-final (write-stat context new-stat)
(match new-stat
[(struct stat (_ _ _ new-mode _ new-mtime new-length new-name _ new-gid _))
(let ([time (or new-mtime (current-seconds))])
(when new-name
(name new-name))
(when new-gid
(set! gid new-gid))
(when new-mode
(set! mode new-mode))
(if (and new-length (zero? new-length))
(truncate context time)
(touch context new-mtime time)))]))
(define/overment (remove context)
(inner (void) remove context)
(name #f))
))
(define server-file/parent<%>
(interface (server-file<%>)
parent))
(define server-file:parent-mixin
(mixin (server-file<%>) (server-file/parent<%>)
(super-new)
(init-field [current-parent (and (is-a? this server-directory%) this)])
(define/override-final parent
(case-lambda
[()
(or current-parent (raise-9p-error ENOSYS))]
[(parent)
(set! current-parent parent)]))
))
(define server-bytes-cursor%
(class server-file-cursor%
(super-new)
(init-field current-content
[can-read? #t]
[can-write? (not (immutable? current-content))]
[can-resize? can-write?]
[commit #f])
(define/public-final content
(case-lambda
[()
current-content]
[(content)
(set! current-content content)]))
(define/augment-final (read size offset)
(if can-read?
(let ([data (content)])
(if (< offset (bytes-length data))
(subbytes data offset (min (+ offset size) (bytes-length data)))
eof))
(raise-9p-error EPERM)))
(define/augment-final (write new-data offset)
(if can-write?
(let ([old-data (content)])
(cond
[(<= (+ offset (bytes-length new-data)) (bytes-length old-data))
(bytes-copy! old-data offset new-data)
(bytes-length new-data)]
[(and can-resize? (<= offset (bytes-length old-data)))
(content
(bytes-append (subbytes old-data 0 (min offset (bytes-length old-data)))
new-data))
(bytes-length new-data)]
[(< offset (bytes-length old-data))
(let ([size (- (bytes-length old-data) offset)])
(bytes-copy! old-data offset new-data 0 size)
size)]
[else
(raise-9p-error EFBIG)]))
(raise-9p-error EPERM)))
(define/augment (clunk)
(inner (void) clunk)
(when commit
(commit (content))))
))
(define server-bytes-file%
(class (server-file:cursor-mixin (server-file:parent-mixin (server-file:stat-mixin server-file%)))
(super-new)
(init-field [current-content #""])
(inherit touch)
(define/public-final content
(case-lambda
[()
current-content]
[(content)
(set! current-content content)]))
(define/override-final (content-length context)
(bytes-length current-content))
(define/augment-final (truncate context time)
(content #""))
(define/override-final (make-cursor context mode)
(let* ([direction (open-mode-direction mode)]
[read? (memv direction (open-direction r r/w x))]
[write? (memv direction (open-direction w r/w))]
[trunc? (not (zero? (bitwise-and mode (open-flag trunc))))]
[data (cond
[(and write? trunc?)
(bytes)]
[write?
(bytes-copy (content))]
[else
(content)])]
[commit (and write?
(λ (data)
(content data)
(touch context #t)))])
(touch context #f)
(new server-bytes-cursor%
[current-content data]
[can-read? read?] [can-write? write?] [commit commit])))
))
(define server-value-file%
(class (server-file:cursor-mixin (server-file:parent-mixin (server-file:stat-mixin server-file%)))
(super-new)
(init-field [current-content (void)])
(define bytes-content
#f)
(inherit touch)
(define/public-final content
(case-lambda
[()
current-content]
[(content)
(set!-values (current-content bytes-content)
(values content #f))]))
(define/public-final (content->bytes)
(unless bytes-content
(set! bytes-content
(if (not (void? current-content))
(call-with-output-bytes
(λ (out)
(write current-content out)
(newline out)))
#"")))
bytes-content)
(define/override-final (content-length context)
(bytes-length (content->bytes)))
(define/augment-final (truncate context time)
(content (void)))
(define/override-final (make-cursor context mode)
(let* ([direction (open-mode-direction mode)]
[read? (memv direction (open-direction r r/w x))]
[write? (memv direction (open-direction w r/w))]
[trunc? (not (zero? (bitwise-and mode (open-flag trunc))))]
[data (cond
[(and write? trunc?)
(bytes)]
[write?
(bytes-copy (content->bytes))]
[else
(content->bytes)])]
[commit (and write?
(λ (data)
(content (if (not (zero? (bytes-length data)))
(with-handlers ([exn:fail? (λ (exn) (raise-9p-error EIO))])
(call-with-input-bytes data read))
(void)))
(touch context #t)))])
(touch context #f)
(new server-bytes-cursor%
[current-content data]
[can-read? read?] [can-write? write?] [commit commit])))
))
(define server-port-cursor%
(class server-file-cursor%
(super-new)
(init-field [input-port #f] [block? #f] [output-port #f] [flush? #f] [close? #t] [cleanup #f])
(inherit offset)
(define/public-final (->input-port)
input-port)
(define/public-final (->output-port)
output-port)
(define/augment-final (read size at-offset)
(if input-port
(if (or (zero? at-offset) (= at-offset (offset)))
(with-handlers ([exn:fail?
(λ (exn)
(raise
(make-exn:fail:filesystem:9p
(exn-message exn)
(exn-continuation-marks exn))))])
(let* ([data (make-bytes size)]
[used ((if block? read-bytes! read-bytes-avail!) data (->input-port))])
(cond
[(exact-nonnegative-integer? used)
(subbytes data 0 used)]
[(eof-object? used)
eof]
[else
(raise-9p-error EBADMSG)])))
(raise-9p-error ESPIPE))
(raise-9p-error EPERM)))
(define/augment-final (write data at-offset)
(if output-port
(if (or (zero? at-offset) (= at-offset (offset)))
(with-handlers ([exn:fail?
(λ (exn)
(raise
(make-exn:fail:filesystem:9p
(exn-message exn)
(exn-continuation-marks exn))))])
(begin0
(write-bytes data (->output-port))
(when flush?
(flush-output (->output-port)))))
(raise-9p-error ESPIPE))
(raise-9p-error EPERM)))
(define/augment (clunk)
(let ([pending-exn #f])
(define (recording-exceptions thunk)
(let/ec return
(call-with-exception-handler
(λ (exn)
(set! pending-exn exn)
(return))
thunk)))
(recording-exceptions
(λ () (inner (void) clunk)))
(when close?
(when input-port
(recording-exceptions
(λ () (close-input-port input-port)))
(set! input-port #f))
(when output-port
(recording-exceptions
(λ () (close-output-port output-port)))
(set! output-port #f)))
(when cleanup
(recording-exceptions cleanup))
(when pending-exn
(raise pending-exn))))
))
(define server-log-file%
(class (server-file:parent-mixin (server-file:stat-mixin server-file%))
(super-new)
(init-field [logger (current-logger)] [current-log-level 'info])
(inherit touch)
(define/public-final (->logger)
logger)
(define/public-final log-level
(case-lambda
[()
current-log-level]
[(log-level)
(set! current-log-level log-level)]))
(define/override-final (open context mode)
(values (make-log-receiver (->logger) (log-level))
(- (max-message-size) 24)))
(define/override-final (read context i/o-state size offset)
(let ([data (call-with-output-bytes
(λ (out)
(write (sync i/o-state) out)
(newline out)))])
(touch context #f)
(subbytes data 0 (min size (- (max-message-size) 24) (bytes-length data)))))
))
(define server-hash-directory%
(class (server-file:parent-mixin (server-file:stat-mixin server-directory%))
(super-new)
(init [with-children null])
(inherit touch)
(define current-children
(make-hash))
(for ([file (in-list with-children)])
(add-child file))
(define/override-final (child name)
(hash-ref current-children name (λ () (super child name))))
(define/override-final (in-entries context)
(touch context #f)
(in-generator
(for ([file (in-hash-values current-children)])
(yield (send file read-stat context)))))
(define/private (child-name-changed old-name new-name)
(if (not (hash-has-key? current-children new-name))
(let ([file (child old-name)])
(hash-remove! current-children old-name)
(if new-name
(hash-set! current-children new-name file)
(send file on-name-change this #f)))
(raise-9p-error EEXIST)))
(define/public-final (add-child file)
(unless (and (is-a? file server-file/stat<%>)
(is-a? file server-file/parent<%>))
(raise-type-error
'add-child
"server-file/stat<%> and server-file/parent<%>" file))
(let ([name (send file name)])
(if (not (hash-has-key? current-children name))
(begin
(hash-set! current-children name file)
(send file parent this)
(send file on-name-change this (λ (from to) (child-name-changed from to))))
(raise-9p-error EEXIST))))
(define/public-final (remove-child name/file)
(let-values ([(name file)
(cond
[(and (is-a? name/file server-file/stat<%>)
(is-a? name/file server-file/parent<%>))
(values (send name/file name) name/file)]
[(string? name/file)
(values name/file (child name/file))]
[else
(raise-type-error
'remove-child
"server-file/stat<%> and server-file/parent<%> or string" name/file)])])
(hash-remove! current-children name)
(send file on-name-change this #f)))
(define/override (create context name perm mode)
(let* ([file% (if (zero? (bitwise-and (file-mode-type perm) (file-type dir)))
server-bytes-file%
server-hash-directory%)]
[write? (memv (open-mode-direction mode) (open-direction w r/w))]
[rclose? (not (zero? (bitwise-and mode (open-flag rclose))))]
[file (new file%
[current-name name]
[mode (file-mode (bitwise-ior (file-mode-type perm)
(if (and write? rclose?)
(type-flag temp)
0))
perm)])])
(unless (and write? rclose?)
(add-child file))
(touch context #t)
file))
))
(provide
server-file/stat<%> server-file:stat-mixin
server-file/parent<%> server-file:parent-mixin
server-bytes-cursor% server-bytes-file% server-value-file%
server-port-cursor%
server-log-file%
server-hash-directory%)