#lang scheme
(require
 scheme/system
 "../main.ss"
 "../network.ss"
 "../errno.ss"
 "data.ss"
 "handle.ss")

(define ((make-t-handler fs) request)
  (let* ([t-fids (current-fids)]
         [fid->file (λ (fid) (hash-ref t-fids fid (λ () (raise-9p-error EBADF))))])
    (match request
      [(struct message:t:auth (tag (box afid) user root))
       (let* ([auth (send fs authenticate root #:user user)]
              [stat (send auth read-stat)])
         (hash-set! t-fids afid auth)
         (make-message:r:auth tag (stat-qid stat)))]
      [(struct message:t:attach (tag (box fid) afid user root))
       (let* ([file (send fs attach root #:token (fid->file afid) #:user user)]
              [stat (send file read-stat)])
         (hash-set! t-fids fid file)
         (make-message:r:attach tag (stat-qid stat)))]
      [(struct message:t:stat (tag fid))
       (make-message:r:stat tag (send (fid->file fid) read-stat))]
      [(struct message:t:wstat (tag fid stat))
       (send (fid->file fid) write-stat stat)
       (make-message:r:wstat tag)]
      [(struct message:t:walk (tag from-fid (box to-fid) names))
       (let*-values ([(from-file)
                      (fid->file from-fid)]
                     [(to-file qids)
                      (if (zero? (vector-length names))
                          (let ([file (send from-file walk)])
                            (values file '#()))
                          (let/ec break
                            (for/fold ([file from-file]
                                       [qids (make-vector (vector-length names))])
                              ([name (in-vector names)]
                               [i (in-naturals)])
                              (with-handlers ([exn:fail:filesystem:9p?
                                               (λ (exn)
                                                 (if (positive? i)
                                                     (break #f (vector-take qids i))
                                                     (raise exn)))])
                                (let* ([file (send from-file walk name)]
                                       [stat (send file read-stat)])
                                  (vector-set! qids i (stat-qid stat))
                                  (values file qids))))))])
         (when to-file
           (hash-set! t-fids to-fid to-file))
         (make-message:r:walk tag qids))]
      [(struct message:t:create (tag fid name perm mode))
       (let ([old-file (fid->file fid)])
         (if (is-a? old-file directory-handle<%>)
             (let*-values ([(new-file i/o-unit) (send old-file create name perm mode)]
                           [(stat) (send new-file read-stat)])
               (hash-set! t-fids fid new-file)
               (send old-file clunk)
               (make-message:r:create tag (stat-qid stat) i/o-unit))
             (make-message:r:error tag ENOTDIR)))]
      [(struct message:t:open (tag fid mode))
       (let* ([file (fid->file fid)]
              [i/o-unit (send file open mode)]
              [stat (send file read-stat)])
         (make-message:r:open tag (stat-qid stat) i/o-unit))]
      [(struct message:t:read (tag fid offset size))
       (let ([data (send (fid->file fid) read size offset)])
         (make-message:r:read tag (if (eof-object? data) #"" data)))]
      [(struct message:t:write (tag fid offset data))
       (make-message:r:write tag (send (fid->file fid) write data offset))]
      [(struct message:t:clunk (tag fid))
       (let ([file (fid->file fid)])
         (hash-remove! t-fids fid)
         (send file clunk)
         (make-message:r:clunk tag))]
      [(struct message:t:remove (tag fid))
       (let ([file (fid->file fid)])
         (hash-remove! t-fids fid)
         (send file remove)
         (make-message:r:remove tag))]
      [(struct message:t (tag))
       (make-message:r:error tag ENOSYS)])))

(define server-filesystem%
  (class* object% (filesystem<%>)
    
    (super-new)
    
    (init-field [port-no 564] [hostname #f] [9wrapper (find-executable-path "9")])
    
    (init [with-root #f] [with-roots #f] [max-allow-wait 4] [reuse? #f])
    
    (define roots
      (cond
        [(or (and with-root with-roots) (not (or with-root with-roots)))
         (error 'server-filesystem% "expected either with-root or with-roots init argument")]
        [with-root
         (list (cons "" with-root))]
        [else
         with-roots]))
    
    (define custodian
      (start-server
       (make-t-handler this) (λ (handle) (send handle clunk))
       port-no max-allow-wait reuse? hostname))
    
    (define mountpoint
      #f)
    
    (define/public (make-context user)
      (new server-context% [user user]))
    
    (define/public (authenticate root #:user user)
      (raise-9p-error ENOSYS))
    
    (define/public-final (attach root #:user user #:token auth)
      (let ([root (dict-ref roots root (λ () (raise-9p-error ENOENT)))]
            [context (if auth (send auth context) (make-context user))])
        (send root attach context)))
    
    (define/public-final (mount at-mountpoint)
      (cond
        [(not (dict-ref roots "" #f))
         (error 'mount "filesystem has no default root")]
        [(not 9wrapper)
         (error 'mount "Plan9 tool wrapper not available")]
        [mountpoint
         (error 'mount "filesystem already mounted at ~e" mountpoint)]
        [else
         (let* ([at-mountpoint (path->string (expand-user-path at-mountpoint))]
                [success? (system* 9wrapper "mount"
                                   (format "tcp!~a!~a" (or hostname "localhost") port-no)
                                   at-mountpoint)])
           (when success?
             (set! mountpoint at-mountpoint))
           success?)]))
    
    (define/public-final (unmount)
      (let ([success? (and mountpoint (system* 9wrapper "unmount" mountpoint))])
        (when success?
          (set! mountpoint #f))
        success?))
      
    (define/pubment (clunk)
      (when custodian
        (dynamic-wind
         void
         (λ ()
           (inner (void) clunk))
         (λ ()
           (unmount)
           (custodian-shutdown-all custodian)
           (set! custodian #f)))))
    
    ))

(provide
 server-filesystem%)