#lang scheme
(require
 (planet murphy/packed-io:1:0)
 "../main.ss"
 "../errno.ss"
 (only-in "../network/message.ss" max-message-size)
 "data.ss")

(define server-file-handle%
  (class* object% (file-handle<%>)
    
    (super-new)
    
    (init-field file context [current-i/o-state #f])
    
    (define/public-final (->file)
      (or file (raise-9p-error ESTALE)))
    
    (define/public-final (->context)
      context)
    
    (define/public-final walk
      (case-lambda
        [()
         (walk-self)]
        [(name)
         (if (string=? name "..")
             (walk-parent)
             (walk-child name))]
        [names
         (foldl
          (λ (name file)
            (send file walk name))
          this names)]))
    
    (define/public-final (walk-self)
      (let ([file (->file)] [context (->context)])
        (send file attach context)))
    
    (define/public-final (walk-parent)
      (let ([file (->file)] [context (->context)])
        (send (send file parent) attach context)))
    
    (define/public (walk-child name)
      (raise-9p-error ENOTDIR))
    
    (define/public-final (read-stat)
      (let ([file (->file)] [context (->context)])
        (send file read-stat context)))
    
    (define/public-final (write-stat new-stat)
      (let* ([file (->file)] [context (->context)]
             [mode (match new-stat
                     [(struct stat (#f #f #f
                                    (and mode
                                         (or #f
                                             (? (λ (mode)
                                                  (eq? (zero? (bitwise-and (file-mode-type mode)
                                                                           (file-type dir)))
                                                       (not (is-a? file server-directory%)))))))
                                    _
                                    mtime
                                    (and length (or #f 0))
                                    name
                                    #f
                                    (and gid
                                         (or #f
                                             (? (λ (gid) (send context in-group? gid)))))
                                    #f))
                      (filter
                       symbol?
                       (list (and mode (touch-mode mode))
                             (and mtime (touch-mode mtime))
                             (and length (touch-mode length))
                             (and name (touch-mode name))
                             (and gid (touch-mode gid))))]
                     [_
                      (raise-9p-error EINVAL)])])
        (if (send context can-touch? file mode)
            (send file write-stat context new-stat)
            (raise-9p-error EACCESS))))
    
    (define/public-final (i/o-state)
      current-i/o-state)
    
    (define/public-final (open mode)
      (if (not current-i/o-state)
          (let ([file (->file)] [context (->context)])
            (if (send context can-access? file mode)
                (let-values ([(i/o-state i/o-unit) (send file open context mode)])
                  (set! current-i/o-state i/o-state)
                  i/o-unit)
                (raise-9p-error EACCESS)))
          (raise-9p-error EISCONN)))
    
    (define/public-final (read size offset)
      (if current-i/o-state
          (send (->file) read (->context) (i/o-state) size offset)
          (raise-9p-error ENOTCONN)))
    
    (define/public-final (write data offset)
      (if current-i/o-state
          (send (->file) write (->context) (i/o-state) data offset)
          (raise-9p-error ENOTCONN)))
    
    (define/private (invalidate thunk)
      (when file
        (let ([pending-exn #f])
          (define (recording-exceptions thunk)
            (let/ec return
              (call-with-exception-handler
               (λ (exn)
                 (set! pending-exn exn)
                 (return))
               thunk)))
          (when current-i/o-state
            (recording-exceptions
             (λ () (send (->file) clunk (->context) (i/o-state))))
            (set! current-i/o-state #f))
          (recording-exceptions
           (λ () (inner (void) clunk)))
          (recording-exceptions
           thunk)
          (set! file #f)
          (when pending-exn
            (raise pending-exn)))))
    
    (define/pubment (clunk)
      (invalidate void))
    
    (define/public-final (remove)
      (invalidate
       (λ ()
         (let ([file (->file)] [context (->context)])
           (if (send context can-remove? file)
               (send file remove context)
               (raise-9p-error EACCESS))))))
    
    ))

(define server-directory-handle%
  (class* server-file-handle% (directory-handle<%>)
    
    (super-new)
    
    (inherit ->file ->context)
    
    (define/override-final (walk-child name)
      (let ([file (->file)] [context (->context)])
        (if (send context can-access? file (open-mode x))
            (send (send file child name) attach context)
            (raise-9p-error EACCESS))))
    
    (define/public-final (in-entries)
      (let ([file (->file)] [context (->context)])
        (if (send context can-access? file (open-mode r))
            (send file in-entries context)
            (raise-9p-error EACCESS))))
    
    (define/public-final (create name perm mode)
      (let ([file (->file)] [context (->context)])
        (if (send context can-access? file (open-mode w))
            (send (send file create context name perm mode) attach context mode)
            (raise-9p-error EACCESS))))
    
    ))

(define server-file%
  (class object%
    
    (super-new)
         
    (define/public (parent)
      (raise-9p-error ENOSYS))

    (define/public (attach context [mode #f])
      (let*-values ([(i/o-state i/o-unit)
                     (if mode (open context mode) (values #f #f))]
                    [(handle)
                     (new server-file-handle%
                          [file this] [context context] [current-i/o-state i/o-state])])
        (if mode
            (values handle (or i/o-unit 0))
            handle)))
    
    (define/public (read-stat context)
      (raise-9p-error ENOSYS))
    
    (define/public (write-stat context stat)
      (raise-9p-error EROFS))
    
    (define/public (open context mode)
      (values #t (- (max-message-size) 24)))
    
    (define/public (read context i/o-state size offset)
      eof)
    
    (define/public (write context i/o-state data offset)
      (raise-9p-error EROFS))
    
    (define/public (clunk context i/o-state)
      (void))
    
    (define/public (remove context)
      (raise-9p-error EROFS))
    
    ))

(define server-file<%>
  (class->interface server-file%))

(define server-file-cursor%
  (class object%
    
    (super-new)
    
    (init-field [current-offset 0] [with-i/o-unit (- (max-message-size) 24)])
    
    (define/public-final offset
      (case-lambda
        [()
         (or current-offset (raise-9p-error ENOTCONN))]
        [(position)
         (set! current-offset position)]))
    
    (define/public-final (i/o-unit)
      with-i/o-unit)
    
    (define/pubment (read size [at-offset (offset)])
      (if current-offset
          (let ([data (inner eof read (min size (i/o-unit)) at-offset)])
            (when (bytes? data)
              (offset (+ at-offset (bytes-length data))))
            data)
          (raise-9p-error ENOTCONN)))
    
    (define/pubment (write data [at-offset (offset)])
      (if current-offset
          (let ([size (inner (raise-9p-error EROFS) write data at-offset)])
            (offset (+ at-offset size))
            size)
          (raise-9p-error ENOTCONN)))
    
    (define/pubment (clunk)
      (when current-offset
        (dynamic-wind
         void
         (λ ()
           (inner (void) clunk))
         (λ ()
           (set! current-offset #f)))))
    
    ))

(define server-file:cursor-mixin
  (mixin (server-file<%>) ()
    
    (super-new)
    
    (define/public (make-cursor context mode)
      (raise-9p-error ENOSYS))
    
    (define/override-final (open context mode)
      (let ([cursor (make-cursor context mode)])
        (values cursor (send cursor i/o-unit))))
    
    (define/override-final (read context cursor size offset)
      (send cursor read size offset))
    
    (define/override-final (write context cursor data offset)
      (send cursor write data offset))
    
    (define/override-final (clunk context cursor)
      (send cursor clunk))
    
    ))

(define server-directory-cursor%
  (class server-file-cursor%
    
    (super-new)
    
    (init-field entries)
    
    (inherit i/o-unit offset)
    
    (define-values (peek-entry drop-entry!)
      (values #f #f))
    
    (define/private (reset)
      (set!-values (peek-entry drop-entry!)
        (let-values ([(has-next-entry? next-entry) (sequence-generate entries)]
                     [(buffered-entry) #f])
          (values
           (λ ()
             (unless buffered-entry
               (set! buffered-entry
                 (if (has-next-entry?) (pack stat/p (next-entry)) eof)))
             buffered-entry)
           (λ ()
             (set! buffered-entry #f))))))
    
    (define/augment-final (read size at-offset)
      (cond
        [(zero? at-offset)
         (reset)]
        [(not (= at-offset (offset)))
         (raise-9p-error ESPIPE)])
      (call-with-output-bytes
       (λ (out)
         (let more ()
           (let ([pos (file-position out)] [entry (peek-entry)])
             (when (and (not (eof-object? entry)) (<= (+ pos (bytes-length entry)) size))
               (drop-entry!)
               (write-bytes entry out)
               (more)))))))
    
    (define/augment-final (write data offset)
      (raise-9p-error EISDIR))
    
    (define/augment (clunk)
      (inner (void) clunk)
      (set!-values (peek-entry drop-entry!)
        (values #f #f)))
    
    ))

(define server-directory%
  (class (server-file:cursor-mixin server-file%)
    
    (super-new)
    
    (define/public (child name)
      (raise-9p-error ENOENT))
    
    (define/public (in-entries context)
      (in-list null))
    
    (define/override-final (make-cursor context mode)
      (new server-directory-cursor% [entries (in-entries context)]))
    
    (define/override (attach context [mode #f])
      (let ([handle (new server-directory-handle% [file this] [context context])])
        (if mode
            (values handle 0)
            handle)))
    
    (define/public (create context name perm mode)
      (raise-9p-error EROFS))
    
    ))

(define server-directory<%>
  (class->interface server-directory%))

(provide
 server-file-handle% server-directory-handle%
 server-file<%> server-file%
 server-file-cursor% server-file:cursor-mixin
 server-directory-cursor%
 server-directory<%> server-directory%)