(use 9p-server 9p-lolevel tcp)

(define (dump-message Ttype message)
  (printf "~S: ~S\n" Ttype message))

(define (dump-message-fid Ttype message fid-value)
  (printf "~S: ~S ~S\n" Ttype message fid-value))

(define (handle-version message)
  (dump-message 'Tversion message)
  16384)

(define (handle-auth message bind-fid! reply! error!)
  (dump-message 'Tauth message)
  (error! "You don't need to authenticate with me.")
  (void))

(define (handle-flush message reply! error!)
  (dump-message 'Tflush message)
  (reply! '())
  (void))

(define (handle-attach message auth-fid-value bind-fid! reply! error!)
  (dump-message-fid 'Tattach message auth-fid-value)
  (bind-fid! "/")
  (reply! (list (make-qid qtdir 0 0))))

(define (handle-walk message parent-fid-value bind-fid! reply! error!)
  (dump-message-fid 'Twalk message parent-fid-value)
  (error! "Not yet implemented"))

(define (handle-open message fid-value reply! error!)
  (dump-message-fid 'Topen message fid-value)
  (error! "Not yet implemented"))

(define (handle-create message fid-value reply! error!)
  (dump-message-fid 'Tcreate message fid-value)
  (error! "Not yet implemented"))

(define (handle-read message fid-value reply! error!)
  (dump-message-fid 'Tread message fid-value)
  (error! "Not yet implemented"))

(define (handle-write message fid-value reply! error!)
  (dump-message-fid 'Twrite message fid-value)
  (error! "Not yet implemented"))

(define (handle-clunk message fid-value reply! error!)
  (dump-message-fid 'Tclunk message fid-value)
  (reply! '()))

(define (handle-remove message fid-value reply! error!)
  (dump-message-fid 'Tremove message fid-value)
  (error! "Not yet implemented"))

(define (handle-stat message fid-value reply! error!)
  (dump-message-fid 'Tstat message fid-value)
  (error! "Not yet implemented"))

(define (handle-wstat message fid-value reply! error!)
  (dump-message-fid 'Twstat message fid-value)
  (error! "Not yet implemented"))

(define (handle-disconnect)
  (printf "Disconnected\n"))

(let ((listener (tcp-listen 1564)))
  (let accept-loop ()
    (receive (in out) (tcp-accept listener)
             (printf "New connection!\n")
             (serve in out
                    handle-version handle-auth handle-flush
                    handle-attach handle-walk handle-open
                    handle-create handle-read handle-write
                    handle-clunk handle-remove handle-stat
                    handle-wstat handle-disconnect)
             (close-input-port in)
             (close-output-port out))))