#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%)