#lang scheme
(require
 (for-syntax scheme/match scheme/struct-info)
 (planet murphy/packed-io:1:0)
 "../data.ss"
 "../exception.ss"
 "../errno.ss")

(define ((make-id-wrapper ids max-id ename) id-box)
  (or (unbox id-box)
      (let retry ()
        (if (and (hash? (ids)) (< (hash-count (ids)) max-id))
            (let ([id (random max-id)])
              (if (not (hash-has-key? (ids) id))
                  (begin
                    (hash-set! (ids) id #t)
                    (set-box! id-box id)
                    id)
                  (retry)))
            (raise-9p-error ename)))))

(define current-tags
  (make-parameter #f))

(define tag/p
  (wrap/p
   box-immutable
   (make-id-wrapper current-tags #xffff EAGAIN)
   ushort/p
   (box/c (or/c (packing-contract ushort/p) #f))))

(provide
 current-tags tag/p)

(define current-fids
  (make-parameter #f))

(define fid/p
  (wrap/p
   box-immutable
   (make-id-wrapper current-fids #xffffff EMFILE)
   uint/p
   (box/c (or/c (packing-contract uint/p) #f))))

(provide
 current-fids fid/p)

(define-struct message
  (tag)
  #:transparent)

(define-struct (message:t message)
  ()
  #:transparent)

(define-struct (message:r message)
  ()
  #:transparent)

(define-values (prop:message-id message-id? message-id)
  (make-struct-type-property 'message-id))

(define message-packings
  (make-hash))

(define-syntax (define-message-packing stx)
  (syntax-case stx ()
    [(define-message-packing name (packing ...))
     (match (extract-struct-info (syntax-local-value #'name))
       [(list type constructor predicate getters setters super)
        (with-syntax ([type type]
                      [constructor constructor]
                      [predicate predicate]
                      [(getter ...) (datum->syntax type (reverse getters))])
          #'(hash-set! message-packings (message-id type)
              (wrap/p
               (λ (v)
                 (apply constructor v))
               (λ (v)
                 (list (getter v) ...))
               (list/p tag/p packing ...)
               predicate)))])]))

(define-syntax (define-message-type stx)
  (syntax-case stx ()
    [(define-message-type (name super) id
       ([field packing-expr] ...))
     (with-syntax ([(packing ...) (generate-temporaries #'(field ...))])
       #'(begin
           (define-struct (name super)
             (field ...)
             #:transparent
             #:property prop:message-id id)
           (define-values (packing ...)
             (values packing-expr ...))
           (define-message-packing name
             (packing ...))
           (provide/contract
            (struct (name message) ([tag (packing-contract tag/p)]
                                    [field (packing-contract packing)] ...)))))]))

(provide/contract
 (struct message ([tag (packing-contract tag/p)]))
 (struct message:t ([tag (packing-contract tag/p)]))
 (struct message:r ([tag (packing-contract tag/p)])))

(define-message-type (message:t:version message:t) 100
  ([max-size uint/p]
   [version nstring/p]))
(define-message-type (message:r:version message:r) 101
  ([max-size uint/p]
   [version nstring/p]))

(define-message-type (message:t:auth message:t) 102
  ([afid fid/p]
   [user nstring/p]
   [root nstring/p]))
(define-message-type (message:r:auth message:r) 103
  ([aqid qid/p]))

(define-message-type (message:t:attach message:t) 104
  ([fid fid/p]
   [afid uint/p]
   [user nstring/p]
   [root nstring/p]))
(define-message-type (message:r:attach message:r) 105
  ([qid qid/p]))

; (define-message-type (message:t:error message:t) 106
;   ())
(define-message-type (message:r:error message:r) 107
  ([name nstring/p]))

(define-message-type (message:t:flush message:t) 108
  ([old-tag ushort/p]))
(define-message-type (message:r:flush message:r) 109
  ())

(define-message-type (message:t:walk message:t) 110
  ([from-fid uint/p]
   [to-fid fid/p]
   [names (with-count/p 2 nstring/p)]))
(define-message-type (message:r:walk message:r) 111
  ([qids (with-count/p 2 qid/p)]))

(define-message-type (message:t:open message:t) 112
  ([fid uint/p]
   [mode ubyte/p]))
(define-message-type (message:r:open message:r) 113
  ([qid qid/p]
   [i/o-unit uint/p]))

(define-message-type (message:t:openfd message:t) 98
  ([fid uint/p]
   [mode ubyte/p]))
(define-message-type (message:r:openfd message:r) 99
  ([qid qid/p]
   [i/o-unit uint/p]
   [fd uint/p]))

(define-message-type (message:t:create message:t) 114
  ([fid uint/p]
   [name nstring/p]
   [permissions uint/p]
   [mode ubyte/p]))
(define-message-type (message:r:create message:r) 115
  ([qid qid/p]
   [i/o-unit uint/p]))

(define-message-type (message:t:read message:t) 116
  ([fid uint/p]
   [offset ulong/p]
   [size uint/p]))
(define-message-type (message:r:read message:r) 117
  ([data nbytes/p]))

(define-message-type (message:t:write message:t) 118
  ([fid uint/p]
   [offset ulong/p]
   [data nbytes/p]))
(define-message-type (message:r:write message:r) 119
  ([size uint/p]))

(define-message-type (message:t:clunk message:t) 120
  ([fid uint/p]))
(define-message-type (message:r:clunk message:r) 121
  ())

(define-message-type (message:t:remove message:t) 122
  ([fid uint/p]))
(define-message-type (message:r:remove message:r) 123
  ())

(define-message-type (message:t:stat message:t) 124
  ([fid uint/p]))
(define-message-type (message:r:stat message:r) 125
  ([stat (with-size/p 2 stat/p)]))

(define-message-type (message:t:wstat message:t) 126
  ([fid uint/p]
   [stat (with-size/p 2 stat/p)]))
(define-message-type (message:r:wstat message:r) 127
  ())

(define frame/p
  (cons/p uint/p ubyte/p))

(define max-message-size
  (make-parameter 4096))

(define (read-message [in (current-input-port)])
  (parameterize ([packing-big-endian? #f])
    (match (read-packed frame/p in)
      [(cons size id)
       (when (> size (max-message-size))
         (error 'read-message "maximum message size exceeded: (> ~s ~s)" size (max-message-size)))
       (read-packed (hash-ref message-packings id) (make-limited-input-port in (- size 5)))]
      [_
       eof])))

(define (write-message message [out (current-output-port)])
  (parameterize ([packing-big-endian? #f])
    (let* ([id (message-id message)]
           [content (pack (hash-ref message-packings id) message)]
           [size (+ (bytes-length content) 5)])
      (when (> size (max-message-size))
        (error 'write-message "maximum message size exceeded: (> ~s ~s)" size (max-message-size)))
      (write-packed frame/p (cons size id) out)
      (write-bytes content out))))

(provide/contract
 [max-message-size (parameter/c natural-number/c)]
 [read-message (->* () (input-port?) (or/c message? eof-object?))]
 [write-message (->* ((and/c message? message-id?)) (output-port?) any)])