#lang scheme
(require
 (planet untyped/unlib:3:20/enumeration)
 (planet murphy/packed-io:1:0))

(define (unsigned-integer*/p size)
  (let ([guard (sub1 (expt 2 (* 8 size)))])
    (wrap/p
     (λ (v)
       (and (not (= v guard)) v))
     (λ (v)
       (or v guard))
     (integer/p size #f)
     (or/c (integer-in 0 (sub1 guard)) #f))))

(define ushort*/p
  (unsigned-integer*/p 2))
(define uint*/p
  (unsigned-integer*/p 4))
(define ulong*/p
  (unsigned-integer*/p 8))

(define nstring/p
  (with-size/p 2 (with-eof-value/p "" string/p)))

(define nstring*/p
  (wrap/p
   (λ (v)
     (and (not (zero? (string-length v))) v))
   (λ (v)
     (or v ""))
   nstring/p
   (or/c string? #f)))

(define nbytes/p
  (with-size/p 4 (with-eof-value/p #"" bytes/p)))

(provide
 nstring/p nbytes/p)

(define-struct qid
  (type version path)
  #:prefab)

(define qid/p
  (wrap/p
   (λ (v)
     (apply make-qid v))
   (λ (v)
     (list (qid-type v) (qid-version v) (qid-path v)))
   (list/p ubyte/p uint/p ulong/p)
   qid?))

(define qid*/p
  (wrap/p
   (λ (v)
     (and (not (equal? v '#s(qid #xff #xffffffff #xffffffffffffffff))) v))
   (λ (v)
     (or v '#s(qid #xff #xffffffff #xffffffffffffffff)))
   qid/p
   (or/c qid? #f)))

(provide/contract
 (struct qid ([type (packing-contract ubyte/p)]
              [version (packing-contract uint/p)]
              [path (packing-contract ulong/p)])))

(provide
 qid/p)

(define-struct stat
  (type dev qid mode atime mtime length name uid gid muid)
  #:prefab)

(define stat/p
  (wrap/p
   (λ (v)
     (apply make-stat v))
   (λ (v)
     (list (stat-type v) (stat-dev v) (stat-qid v) (stat-mode v)
           (stat-atime v) (stat-mtime v) (stat-length v) (stat-name v)
           (stat-uid v) (stat-gid v) (stat-muid v)))
   (with-size/p 2 (list/p ushort*/p uint*/p qid*/p uint*/p
                          uint*/p uint*/p ulong*/p nstring*/p
                          nstring*/p nstring*/p nstring*/p))
   stat?))

(provide/contract
 (struct stat ([type (packing-contract ushort*/p)]
               [dev (packing-contract uint*/p)]
               [qid (packing-contract qid*/p)]
               [mode (packing-contract uint*/p)]
               [atime (packing-contract uint*/p)]
               [mtime (packing-contract uint*/p)]
               [length (packing-contract ulong*/p)]
               [name (packing-contract nstring*/p)]
               [uid (packing-contract nstring*/p)]
               [gid (packing-contract nstring*/p)]
               [muid (packing-contract nstring*/p)])))

(provide
 stat/p)

(define-enum type-flag
  ([file   #x00 "regular file"]
   [dir    #x80 "directory"]
   [append #x40 "append-only"]
   [excl   #x20 "exclusive"]
   [mount  #x10 "mount point"]
   [auth   #x08 "auth channel"]
   [temp   #x04 "temporary"]))

(define-syntax file-type
  (syntax-rules ()
    [(file-type f ...)
     (bitwise-ior (type-flag f ...))]))

(define-enum access-flag
  ([e 0 "exists"]
   [x 1 "exec"]
   [w 2 "write"]
   [r 4 "read"]))

(define-syntax file-mode
  (syntax-rules (type user group other)
    [(file-mode (type t ...) (user u ...) (group g ...) (others o ...))
     (file-mode (bitwise-ior (type-flag t) ...)
                (file-mode (user u ...) (group g ...) (others o ...)))]
    [(file-mode (user u ...) (group g ...) (others o ...))
     (bitwise-ior (arithmetic-shift (bitwise-ior (access-flag u) ...) 6)
                  (arithmetic-shift (bitwise-ior (access-flag g) ...) 3)
                  (access-flag o) ...)]
    [(file-mode t p)
     (bitwise-ior (arithmetic-shift t 24) p)]))

(define (file-mode-type m)
  (bitwise-bit-field m 24 32))
(define (file-mode-user m)
  (bitwise-bit-field m 6 9))
(define (file-mode-group m)
  (bitwise-bit-field m 3 6))
(define (file-mode-others m)
  (bitwise-bit-field m 0 3))

(define-enum open-direction
  ([r 0 "read"]
   [w 1 "write"]
   [r/w 2 "read or write"]
   [x 3 "exec"]))

(define-enum open-flag
  ([trunc  #x10 "truncate"]
   [rclose #x40 "remove on close"]))

(define-syntax open-mode
  (syntax-rules ()
    [(open-mode s f ...)
     (bitwise-ior (open-direction s) (open-flag f) ...)]))

(define (open-mode-direction m)
  (bitwise-and m #x0f))
(define (open-mode-flags m)
  (bitwise-and m #xf0))

(provide
 type-flag file-type access-flag file-mode
 file-mode-type file-mode-user file-mode-group file-mode-others
 open-direction open-flag open-mode
 open-mode-direction open-mode-flags)