Add 9P2000 filesystem protocol implementation (#31)
ober
2d0e16d0ef139325cfa5384f6ffd7a613387cab6
new file mode 100644 --- /dev/null +++ b/lib/std/net/9p.sls @@ -0,0 +1,607 @@ +#!chezscheme +;;; (std net 9p) -- 9P2000 filesystem protocol (Plan 9) +;;; +;;; Pure encoding/decoding of 9P2000 wire-format messages. +;;; No network I/O -- works entirely with bytevectors. +;;; +;;; Wire format: [4-byte LE size][1-byte type][2-byte LE tag][fields...] +;;; Strings: [2-byte LE length][UTF-8 bytes] + +(library (std net 9p) + (export + ;; Message type constants + p9-type-tversion p9-type-rversion + p9-type-tauth p9-type-rauth + p9-type-tattach p9-type-rattach + p9-type-rerror + p9-type-twalk p9-type-rwalk + p9-type-topen p9-type-ropen + p9-type-tcreate p9-type-rcreate + p9-type-tread p9-type-rread + p9-type-twrite p9-type-rwrite + p9-type-tclunk p9-type-rclunk + p9-type-tstat p9-type-rstat + ;; Qid accessors + make-p9-qid p9-qid? p9-qid-type p9-qid-version p9-qid-path + ;; Message constructors + make-p9-tversion make-p9-rversion + make-p9-tauth make-p9-rauth + make-p9-tattach make-p9-rattach + make-p9-rerror + make-p9-twalk make-p9-rwalk + make-p9-topen make-p9-ropen + make-p9-tcreate make-p9-rcreate + make-p9-tread make-p9-rread + make-p9-twrite make-p9-rwrite + make-p9-tclunk make-p9-rclunk + make-p9-tstat make-p9-rstat + ;; Stat record + make-p9-stat p9-stat? p9-stat-type p9-stat-dev p9-stat-qid + p9-stat-mode p9-stat-atime p9-stat-mtime p9-stat-length + p9-stat-name p9-stat-uid p9-stat-gid p9-stat-muid + ;; Message record accessors (for inspecting decoded messages) + p9-tversion-rec-msize p9-tversion-rec-version + p9-rversion-rec-msize p9-rversion-rec-version + p9-tauth-rec-afid p9-tauth-rec-uname p9-tauth-rec-aname + p9-rauth-rec-aqid + p9-tattach-rec-fid p9-tattach-rec-afid + p9-tattach-rec-uname p9-tattach-rec-aname + p9-rattach-rec-qid + p9-rerror-rec-ename + p9-twalk-rec-fid p9-twalk-rec-newfid p9-twalk-rec-wnames + p9-rwalk-rec-qids + p9-topen-rec-fid p9-topen-rec-mode + p9-ropen-rec-qid p9-ropen-rec-iounit + p9-tcreate-rec-fid p9-tcreate-rec-name + p9-tcreate-rec-perm p9-tcreate-rec-mode + p9-rcreate-rec-qid p9-rcreate-rec-iounit + p9-tread-rec-fid p9-tread-rec-offset p9-tread-rec-count + p9-rread-rec-data + p9-twrite-rec-fid p9-twrite-rec-offset p9-twrite-rec-data + p9-rwrite-rec-count + p9-tclunk-rec-fid + p9-tstat-rec-fid + p9-rstat-rec-stat + ;; Encode / decode + p9-encode p9-decode + ;; Message accessors + p9-message-type p9-message-tag) + + (import (chezscheme)) + + ;;; ========== Message type constants (9P2000) ========== + (define p9-type-tversion 100) + (define p9-type-rversion 101) + (define p9-type-tauth 102) + (define p9-type-rauth 103) + (define p9-type-tattach 104) + (define p9-type-rattach 105) + ;; 106 = Terror (never sent) + (define p9-type-rerror 107) + (define p9-type-twalk 110) + (define p9-type-rwalk 111) + (define p9-type-topen 112) + (define p9-type-ropen 113) + (define p9-type-tcreate 114) + (define p9-type-rcreate 115) + (define p9-type-tread 116) + (define p9-type-rread 117) + (define p9-type-twrite 118) + (define p9-type-rwrite 119) + (define p9-type-tclunk 120) + (define p9-type-rclunk 121) + (define p9-type-tstat 124) + (define p9-type-rstat 125) + + ;;; ========== Qid record ========== + ;; A qid is a 13-byte server-unique file identifier: + ;; [1-byte type][4-byte LE version][8-byte LE path] + (define-record-type p9-qid-rec + (fields type version path)) + + (define (make-p9-qid type version path) + (make-p9-qid-rec type version path)) + (define (p9-qid? x) (p9-qid-rec? x)) + (define (p9-qid-type q) (p9-qid-rec-type q)) + (define (p9-qid-version q) (p9-qid-rec-version q)) + (define (p9-qid-path q) (p9-qid-rec-path q)) + + ;;; ========== Stat record ========== + (define-record-type p9-stat-rec + (fields type dev qid mode atime mtime length name uid gid muid)) + + (define (make-p9-stat type dev qid mode atime mtime length name uid gid muid) + (make-p9-stat-rec type dev qid mode atime mtime length name uid gid muid)) + (define (p9-stat? x) (p9-stat-rec? x)) + (define (p9-stat-type s) (p9-stat-rec-type s)) + (define (p9-stat-dev s) (p9-stat-rec-dev s)) + (define (p9-stat-qid s) (p9-stat-rec-qid s)) + (define (p9-stat-mode s) (p9-stat-rec-mode s)) + (define (p9-stat-atime s) (p9-stat-rec-atime s)) + (define (p9-stat-mtime s) (p9-stat-rec-mtime s)) + (define (p9-stat-length s) (p9-stat-rec-length s)) + (define (p9-stat-name s) (p9-stat-rec-name s)) + (define (p9-stat-uid s) (p9-stat-rec-uid s)) + (define (p9-stat-gid s) (p9-stat-rec-gid s)) + (define (p9-stat-muid s) (p9-stat-rec-muid s)) + + ;;; ========== Message records ========== + + ;; Each message type is a distinct record. They all carry a tag. + + (define-record-type p9-tversion-rec (fields tag msize version)) + (define-record-type p9-rversion-rec (fields tag msize version)) + (define-record-type p9-tauth-rec (fields tag afid uname aname)) + (define-record-type p9-rauth-rec (fields tag aqid)) + (define-record-type p9-tattach-rec (fields tag fid afid uname aname)) + (define-record-type p9-rattach-rec (fields tag qid)) + (define-record-type p9-rerror-rec (fields tag ename)) + (define-record-type p9-twalk-rec (fields tag fid newfid wnames)) + (define-record-type p9-rwalk-rec (fields tag qids)) + (define-record-type p9-topen-rec (fields tag fid mode)) + (define-record-type p9-ropen-rec (fields tag qid iounit)) + (define-record-type p9-tcreate-rec (fields tag fid name perm mode)) + (define-record-type p9-rcreate-rec (fields tag qid iounit)) + (define-record-type p9-tread-rec (fields tag fid offset count)) + (define-record-type p9-rread-rec (fields tag data)) + (define-record-type p9-twrite-rec (fields tag fid offset data)) + (define-record-type p9-rwrite-rec (fields tag count)) + (define-record-type p9-tclunk-rec (fields tag fid)) + (define-record-type p9-rclunk-rec (fields tag)) + (define-record-type p9-tstat-rec (fields tag fid)) + (define-record-type p9-rstat-rec (fields tag stat)) + + ;; Public constructors + (define (make-p9-tversion tag msize version) + (make-p9-tversion-rec tag msize version)) + (define (make-p9-rversion tag msize version) + (make-p9-rversion-rec tag msize version)) + (define (make-p9-tauth tag afid uname aname) + (make-p9-tauth-rec tag afid uname aname)) + (define (make-p9-rauth tag aqid) + (make-p9-rauth-rec tag aqid)) + (define (make-p9-tattach tag fid afid uname aname) + (make-p9-tattach-rec tag fid afid uname aname)) + (define (make-p9-rattach tag qid) + (make-p9-rattach-rec tag qid)) + (define (make-p9-rerror tag ename) + (make-p9-rerror-rec tag ename)) + (define (make-p9-twalk tag fid newfid wnames) + (make-p9-twalk-rec tag fid newfid wnames)) + (define (make-p9-rwalk tag qids) + (make-p9-rwalk-rec tag qids)) + (define (make-p9-topen tag fid mode) + (make-p9-topen-rec tag fid mode)) + (define (make-p9-ropen tag qid iounit) + (make-p9-ropen-rec tag qid iounit)) + (define (make-p9-tcreate tag fid name perm mode) + (make-p9-tcreate-rec tag fid name perm mode)) + (define (make-p9-rcreate tag qid iounit) + (make-p9-rcreate-rec tag qid iounit)) + (define (make-p9-tread tag fid offset count) + (make-p9-tread-rec tag fid offset count)) + (define (make-p9-rread tag data) + (make-p9-rread-rec tag data)) + (define (make-p9-twrite tag fid offset data) + (make-p9-twrite-rec tag fid offset data)) + (define (make-p9-rwrite tag count) + (make-p9-rwrite-rec tag count)) + (define (make-p9-tclunk tag fid) + (make-p9-tclunk-rec tag fid)) + (define (make-p9-rclunk tag) + (make-p9-rclunk-rec tag)) + (define (make-p9-tstat tag fid) + (make-p9-tstat-rec tag fid)) + (define (make-p9-rstat tag stat) + (make-p9-rstat-rec tag stat)) + + ;;; ========== Message type dispatch ========== + + (define (p9-message-type msg) + (cond + [(p9-tversion-rec? msg) p9-type-tversion] + [(p9-rversion-rec? msg) p9-type-rversion] + [(p9-tauth-rec? msg) p9-type-tauth] + [(p9-rauth-rec? msg) p9-type-rauth] + [(p9-tattach-rec? msg) p9-type-tattach] + [(p9-rattach-rec? msg) p9-type-rattach] + [(p9-rerror-rec? msg) p9-type-rerror] + [(p9-twalk-rec? msg) p9-type-twalk] + [(p9-rwalk-rec? msg) p9-type-rwalk] + [(p9-topen-rec? msg) p9-type-topen] + [(p9-ropen-rec? msg) p9-type-ropen] + [(p9-tcreate-rec? msg) p9-type-tcreate] + [(p9-rcreate-rec? msg) p9-type-rcreate] + [(p9-tread-rec? msg) p9-type-tread] + [(p9-rread-rec? msg) p9-type-rread] + [(p9-twrite-rec? msg) p9-type-twrite] + [(p9-rwrite-rec? msg) p9-type-rwrite] + [(p9-tclunk-rec? msg) p9-type-tclunk] + [(p9-rclunk-rec? msg) p9-type-rclunk] + [(p9-tstat-rec? msg) p9-type-tstat] + [(p9-rstat-rec? msg) p9-type-rstat] + [else (error 'p9-message-type "unknown message type" msg)])) + + (define (p9-message-tag msg) + (cond + [(p9-tversion-rec? msg) (p9-tversion-rec-tag msg)] + [(p9-rversion-rec? msg) (p9-rversion-rec-tag msg)] + [(p9-tauth-rec? msg) (p9-tauth-rec-tag msg)] + [(p9-rauth-rec? msg) (p9-rauth-rec-tag msg)] + [(p9-tattach-rec? msg) (p9-tattach-rec-tag msg)] + [(p9-rattach-rec? msg) (p9-rattach-rec-tag msg)] + [(p9-rerror-rec? msg) (p9-rerror-rec-tag msg)] + [(p9-twalk-rec? msg) (p9-twalk-rec-tag msg)] + [(p9-rwalk-rec? msg) (p9-rwalk-rec-tag msg)] + [(p9-topen-rec? msg) (p9-topen-rec-tag msg)] + [(p9-ropen-rec? msg) (p9-ropen-rec-tag msg)] + [(p9-tcreate-rec? msg) (p9-tcreate-rec-tag msg)] + [(p9-rcreate-rec? msg) (p9-rcreate-rec-tag msg)] + [(p9-tread-rec? msg) (p9-tread-rec-tag msg)] + [(p9-rread-rec? msg) (p9-rread-rec-tag msg)] + [(p9-twrite-rec? msg) (p9-twrite-rec-tag msg)] + [(p9-rwrite-rec? msg) (p9-rwrite-rec-tag msg)] + [(p9-tclunk-rec? msg) (p9-tclunk-rec-tag msg)] + [(p9-rclunk-rec? msg) (p9-rclunk-rec-tag msg)] + [(p9-tstat-rec? msg) (p9-tstat-rec-tag msg)] + [(p9-rstat-rec? msg) (p9-rstat-rec-tag msg)] + [else (error 'p9-message-tag "unknown message type" msg)])) + + ;;; ========== Low-level encoding helpers ========== + + ;; Build a bytevector by appending chunks + (define (bv-append . bvs) + (let* ([total (apply + (map bytevector-length bvs))] + [out (make-bytevector total)]) + (let loop ([bvs bvs] [pos 0]) + (if (null? bvs) + out + (let ([bv (car bvs)]) + (bytevector-copy! bv 0 out pos (bytevector-length bv)) + (loop (cdr bvs) (+ pos (bytevector-length bv)))))))) + + (define (encode-u8 v) + (let ([bv (make-bytevector 1)]) + (bytevector-u8-set! bv 0 (bitwise-and v #xFF)) + bv)) + + (define (encode-u16 v) + (let ([bv (make-bytevector 2)]) + (bytevector-u8-set! bv 0 (bitwise-and v #xFF)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right v 8) #xFF)) + bv)) + + (define (encode-u32 v) + (let ([bv (make-bytevector 4)]) + (bytevector-u8-set! bv 0 (bitwise-and v #xFF)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right v 8) #xFF)) + (bytevector-u8-set! bv 2 (bitwise-and (bitwise-arithmetic-shift-right v 16) #xFF)) + (bytevector-u8-set! bv 3 (bitwise-and (bitwise-arithmetic-shift-right v 24) #xFF)) + bv)) + + (define (encode-u64 v) + (let ([bv (make-bytevector 8)]) + (bytevector-u8-set! bv 0 (bitwise-and v #xFF)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right v 8) #xFF)) + (bytevector-u8-set! bv 2 (bitwise-and (bitwise-arithmetic-shift-right v 16) #xFF)) + (bytevector-u8-set! bv 3 (bitwise-and (bitwise-arithmetic-shift-right v 24) #xFF)) + (bytevector-u8-set! bv 4 (bitwise-and (bitwise-arithmetic-shift-right v 32) #xFF)) + (bytevector-u8-set! bv 5 (bitwise-and (bitwise-arithmetic-shift-right v 40) #xFF)) + (bytevector-u8-set! bv 6 (bitwise-and (bitwise-arithmetic-shift-right v 48) #xFF)) + (bytevector-u8-set! bv 7 (bitwise-and (bitwise-arithmetic-shift-right v 56) #xFF)) + bv)) + + ;; 9P string: [2-byte LE length][UTF-8 bytes] + (define (encode-string s) + (let ([utf (string->utf8 s)]) + (bv-append (encode-u16 (bytevector-length utf)) utf))) + + ;; Qid: [1-byte type][4-byte LE version][8-byte LE path] + (define (encode-qid q) + (bv-append (encode-u8 (p9-qid-type q)) + (encode-u32 (p9-qid-version q)) + (encode-u64 (p9-qid-path q)))) + + ;; Data field: [4-byte LE count][bytes...] + (define (encode-data bv) + (bv-append (encode-u32 (bytevector-length bv)) bv)) + + ;; Stat: encoded as [2-byte LE size][stat-body] + ;; stat-body: type[2] dev[4] qid[13] mode[4] atime[4] mtime[4] length[8] + ;; name[s] uid[s] gid[s] muid[s] + (define (encode-stat st) + (let* ([body (bv-append + (encode-u16 (p9-stat-type st)) + (encode-u32 (p9-stat-dev st)) + (encode-qid (p9-stat-qid st)) + (encode-u32 (p9-stat-mode st)) + (encode-u32 (p9-stat-atime st)) + (encode-u32 (p9-stat-mtime st)) + (encode-u64 (p9-stat-length st)) + (encode-string (p9-stat-name st)) + (encode-string (p9-stat-uid st)) + (encode-string (p9-stat-gid st)) + (encode-string (p9-stat-muid st)))] + [sz (bytevector-length body)]) + (bv-append (encode-u16 sz) body))) + + ;;; ========== Encoding ========== + + ;; Encode message fields (without size/type/tag header) + (define (encode-body msg) + (cond + [(p9-tversion-rec? msg) + (bv-append (encode-u32 (p9-tversion-rec-msize msg)) + (encode-string (p9-tversion-rec-version msg)))] + [(p9-rversion-rec? msg) + (bv-append (encode-u32 (p9-rversion-rec-msize msg)) + (encode-string (p9-rversion-rec-version msg)))] + [(p9-tauth-rec? msg) + (bv-append (encode-u32 (p9-tauth-rec-afid msg)) + (encode-string (p9-tauth-rec-uname msg)) + (encode-string (p9-tauth-rec-aname msg)))] + [(p9-rauth-rec? msg) + (encode-qid (p9-rauth-rec-aqid msg))] + [(p9-tattach-rec? msg) + (bv-append (encode-u32 (p9-tattach-rec-fid msg)) + (encode-u32 (p9-tattach-rec-afid msg)) + (encode-string (p9-tattach-rec-uname msg)) + (encode-string (p9-tattach-rec-aname msg)))] + [(p9-rattach-rec? msg) + (encode-qid (p9-rattach-rec-qid msg))] + [(p9-rerror-rec? msg) + (encode-string (p9-rerror-rec-ename msg))] + [(p9-twalk-rec? msg) + (let ([wnames (p9-twalk-rec-wnames msg)]) + (apply bv-append + (encode-u32 (p9-twalk-rec-fid msg)) + (encode-u32 (p9-twalk-rec-newfid msg)) + (encode-u16 (length wnames)) + (map encode-string wnames)))] + [(p9-rwalk-rec? msg) + (let ([qids (p9-rwalk-rec-qids msg)]) + (apply bv-append + (encode-u16 (length qids)) + (map encode-qid qids)))] + [(p9-topen-rec? msg) + (bv-append (encode-u32 (p9-topen-rec-fid msg)) + (encode-u8 (p9-topen-rec-mode msg)))] + [(p9-ropen-rec? msg) + (bv-append (encode-qid (p9-ropen-rec-qid msg)) + (encode-u32 (p9-ropen-rec-iounit msg)))] + [(p9-tcreate-rec? msg) + (bv-append (encode-u32 (p9-tcreate-rec-fid msg)) + (encode-string (p9-tcreate-rec-name msg)) + (encode-u32 (p9-tcreate-rec-perm msg)) + (encode-u8 (p9-tcreate-rec-mode msg)))] + [(p9-rcreate-rec? msg) + (bv-append (encode-qid (p9-rcreate-rec-qid msg)) + (encode-u32 (p9-rcreate-rec-iounit msg)))] + [(p9-tread-rec? msg) + (bv-append (encode-u32 (p9-tread-rec-fid msg)) + (encode-u64 (p9-tread-rec-offset msg)) + (encode-u32 (p9-tread-rec-count msg)))] + [(p9-rread-rec? msg) + (encode-data (p9-rread-rec-data msg))] + [(p9-twrite-rec? msg) + (bv-append (encode-u32 (p9-twrite-rec-fid msg)) + (encode-u64 (p9-twrite-rec-offset msg)) + (encode-data (p9-twrite-rec-data msg)))] + [(p9-rwrite-rec? msg) + (encode-u32 (p9-rwrite-rec-count msg))] + [(p9-tclunk-rec? msg) + (encode-u32 (p9-tclunk-rec-fid msg))] + [(p9-rclunk-rec? msg) + (make-bytevector 0)] + [(p9-tstat-rec? msg) + (encode-u32 (p9-tstat-rec-fid msg))] + [(p9-rstat-rec? msg) + ;; Rstat wraps the stat in an outer 2-byte length prefix + (let ([inner (encode-stat (p9-rstat-rec-stat msg))]) + (bv-append (encode-u16 (bytevector-length inner)) inner))] + [else (error 'p9-encode "unknown message type" msg)])) + + (define (p9-encode msg) + (let* ([type-byte (p9-message-type msg)] + [tag (p9-message-tag msg)] + [body (encode-body msg)] + ;; total size = 4 (size) + 1 (type) + 2 (tag) + body + [total (+ 4 1 2 (bytevector-length body))]) + (bv-append (encode-u32 total) + (encode-u8 type-byte) + (encode-u16 tag) + body))) + + ;;; ========== Low-level decoding helpers ========== + + ;; Extract a sub-range of a bytevector (Chez bytevector-copy takes only 1 arg) + (define (subbytevector bv start end) + (let* ([len (- end start)] + [out (make-bytevector len)]) + (bytevector-copy! bv start out 0 len) + out)) + + (define (decode-u8 bv pos) + (values (bytevector-u8-ref bv pos) (+ pos 1))) + + (define (decode-u16 bv pos) + (values (+ (bytevector-u8-ref bv pos) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 1)) 8)) + (+ pos 2))) + + (define (decode-u32 bv pos) + (values (+ (bytevector-u8-ref bv pos) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 1)) 8) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 2)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 3)) 24)) + (+ pos 4))) + + (define (decode-u64 bv pos) + (values (+ (bytevector-u8-ref bv pos) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 1)) 8) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 2)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 3)) 24) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 4)) 32) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 5)) 40) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 6)) 48) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 7)) 56)) + (+ pos 8))) + + (define (decode-string bv pos) + (let-values ([(len pos2) (decode-u16 bv pos)]) + (let ([str (utf8->string (subbytevector bv pos2 (+ pos2 len)))]) + (values str (+ pos2 len))))) + + (define (decode-qid bv pos) + (let-values ([(qtype pos1) (decode-u8 bv pos)] + [(qver pos2) (decode-u32 bv (+ pos 1))] + [(qpath pos3) (decode-u64 bv (+ pos 5))]) + (values (make-p9-qid qtype qver qpath) (+ pos 13)))) + + (define (decode-data bv pos) + (let-values ([(count pos2) (decode-u32 bv pos)]) + (values (subbytevector bv pos2 (+ pos2 count)) (+ pos2 count)))) + + (define (decode-stat bv pos) + ;; [2-byte size][stat-body] + (let-values ([(sz pos1) (decode-u16 bv pos)]) + (let-values ([(stype pos2) (decode-u16 bv pos1)] + [(sdev pos3) (decode-u32 bv (+ pos1 2))] + [(sqid pos4) (decode-qid bv (+ pos1 6))]) + (let-values ([(smode pos5) (decode-u32 bv (+ pos1 19))] + [(satime pos6) (decode-u32 bv (+ pos1 23))] + [(smtime pos7) (decode-u32 bv (+ pos1 27))] + [(slen pos8) (decode-u64 bv (+ pos1 31))]) + (let-values ([(sname pos9) (decode-string bv (+ pos1 39))]) + (let-values ([(suid pos10) (decode-string bv pos9)]) + (let-values ([(sgid pos11) (decode-string bv pos10)]) + (let-values ([(smuid pos12) (decode-string bv pos11)]) + (values (make-p9-stat stype sdev sqid smode satime smtime slen + sname suid sgid smuid) + (+ pos1 sz)))))))))) + + ;;; ========== Decoding ========== + + (define (p9-decode bv) + (unless (>= (bytevector-length bv) 7) + (error 'p9-decode "message too short" (bytevector-length bv))) + (let-values ([(size pos0) (decode-u32 bv 0)] + [(type pos1) (decode-u8 bv 4)] + [(tag pos2) (decode-u16 bv 5)]) + (let ([pos 7]) ;; start of body + (cond + [(= type p9-type-tversion) + (let-values ([(msize pos2) (decode-u32 bv pos)]) + (let-values ([(ver pos3) (decode-string bv pos2)]) + (make-p9-tversion tag msize ver)))] + + [(= type p9-type-rversion) + (let-values ([(msize pos2) (decode-u32 bv pos)]) + (let-values ([(ver pos3) (decode-string bv pos2)]) + (make-p9-rversion tag msize ver)))] + + [(= type p9-type-tauth) + (let-values ([(afid pos2) (decode-u32 bv pos)]) + (let-values ([(uname pos3) (decode-string bv pos2)]) + (let-values ([(aname pos4) (decode-string bv pos3)]) + (make-p9-tauth tag afid uname aname))))] + + [(= type p9-type-rauth) + (let-values ([(aqid pos2) (decode-qid bv pos)]) + (make-p9-rauth tag aqid))] + + [(= type p9-type-tattach) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (let-values ([(afid pos3) (decode-u32 bv pos2)]) + (let-values ([(uname pos4) (decode-string bv pos3)]) + (let-values ([(aname pos5) (decode-string bv pos4)]) + (make-p9-tattach tag fid afid uname aname)))))] + + [(= type p9-type-rattach) + (let-values ([(qid pos2) (decode-qid bv pos)]) + (make-p9-rattach tag qid))] + + [(= type p9-type-rerror) + (let-values ([(ename pos2) (decode-string bv pos)]) + (make-p9-rerror tag ename))] + + [(= type p9-type-twalk) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (let-values ([(newfid pos3) (decode-u32 bv pos2)]) + (let-values ([(nwname pos4) (decode-u16 bv pos3)]) + (let loop ([i 0] [p pos4] [acc '()]) + (if (= i nwname) + (make-p9-twalk tag fid newfid (reverse acc)) + (let-values ([(name np) (decode-string bv p)]) + (loop (+ i 1) np (cons name acc))))))))] + + [(= type p9-type-rwalk) + (let-values ([(nwqid pos2) (decode-u16 bv pos)]) + (let loop ([i 0] [p pos2] [acc '()]) + (if (= i nwqid) + (make-p9-rwalk tag (reverse acc)) + (let-values ([(qid np) (decode-qid bv p)]) + (loop (+ i 1) np (cons qid acc))))))] + + [(= type p9-type-topen) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (let-values ([(mode pos3) (decode-u8 bv pos2)]) + (make-p9-topen tag fid mode)))] + + [(= type p9-type-ropen) + (let-values ([(qid pos2) (decode-qid bv pos)]) + (let-values ([(iounit pos3) (decode-u32 bv pos2)]) + (make-p9-ropen tag qid iounit)))] + + [(= type p9-type-tcreate) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (let-values ([(name pos3) (decode-string bv pos2)]) + (let-values ([(perm pos4) (decode-u32 bv pos3)]) + (let-values ([(mode pos5) (decode-u8 bv pos4)]) + (make-p9-tcreate tag fid name perm mode)))))] + + [(= type p9-type-rcreate) + (let-values ([(qid pos2) (decode-qid bv pos)]) + (let-values ([(iounit pos3) (decode-u32 bv pos2)]) + (make-p9-rcreate tag qid iounit)))] + + [(= type p9-type-tread) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (let-values ([(offset pos3) (decode-u64 bv pos2)]) + (let-values ([(count pos4) (decode-u32 bv pos3)]) + (make-p9-tread tag fid offset count))))] + + [(= type p9-type-rread) + (let-values ([(data pos2) (decode-data bv pos)]) + (make-p9-rread tag data))] + + [(= type p9-type-twrite) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (let-values ([(offset pos3) (decode-u64 bv pos2)]) + (let-values ([(data pos4) (decode-data bv pos3)]) + (make-p9-twrite tag fid offset data))))] + + [(= type p9-type-rwrite) + (let-values ([(count pos2) (decode-u32 bv pos)]) + (make-p9-rwrite tag count))] + + [(= type p9-type-tclunk) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (make-p9-tclunk tag fid))] + + [(= type p9-type-rclunk) + (make-p9-rclunk tag)] + + [(= type p9-type-tstat) + (let-values ([(fid pos2) (decode-u32 bv pos)]) + (make-p9-tstat tag fid))] + + [(= type p9-type-rstat) + ;; Rstat has an outer 2-byte length prefix around the stat + (let-values ([(outer-len pos2) (decode-u16 bv pos)]) + (let-values ([(st pos3) (decode-stat bv pos2)]) + (make-p9-rstat tag st)))] + + [else (error 'p9-decode "unknown message type" type)])))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-9p.ss @@ -0,0 +1,325 @@ +#!chezscheme +;;; Tests for (std net 9p) -- 9P2000 filesystem protocol + +(import (chezscheme) (std net 9p)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +;; Helper: encode then decode, return decoded message +(define (roundtrip msg) + (p9-decode (p9-encode msg))) + +;; Helper: compare qids +(define (qid=? a b) + (and (= (p9-qid-type a) (p9-qid-type b)) + (= (p9-qid-version a) (p9-qid-version b)) + (= (p9-qid-path a) (p9-qid-path b)))) + +(printf "--- 9P2000 Protocol Tests ---~%~%") + +;;; ========== Wire format basics ========== + +(printf "~%== Wire format ==~%") + +(test "encode-size-prefix" + ;; Tversion with msize=8192, version="9P2000" should have correct size + ;; size[4] + type[1] + tag[2] + msize[4] + strlen[2] + "9P2000"[6] = 19 + (let ([bv (p9-encode (make-p9-tversion 0 8192 "9P2000"))]) + (+ (bytevector-u8-ref bv 0) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 1) 8) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 2) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 3) 24))) + 19) + +(test "encode-type-byte" + ;; Type byte is at offset 4 + (bytevector-u8-ref (p9-encode (make-p9-tversion 0 8192 "9P2000")) 4) + 100) ;; Tversion = 100 + +(test "encode-tag-le" + ;; Tag at offset 5-6, little-endian + (let ([bv (p9-encode (make-p9-tversion #x0102 8192 "9P2000"))]) + (list (bytevector-u8-ref bv 5) (bytevector-u8-ref bv 6))) + '(2 1)) ;; LE: low byte first + +;;; ========== Tversion / Rversion ========== + +(printf "~%== Version ==~%") + +(test "tversion-roundtrip-type" + (p9-message-type (roundtrip (make-p9-tversion 1 8192 "9P2000"))) + p9-type-tversion) + +(test "tversion-roundtrip-tag" + (p9-message-tag (roundtrip (make-p9-tversion 42 8192 "9P2000"))) + 42) + +(let ([msg (roundtrip (make-p9-tversion #xFFFF 8192 "9P2000"))]) + (test "tversion-msize" + (p9-tversion-rec-msize msg) + 8192) + (test "tversion-version-string" + (p9-tversion-rec-version msg) + "9P2000") + (test "tversion-notag" + (p9-message-tag msg) + #xFFFF)) + +(let ([msg (roundtrip (make-p9-rversion 1 4096 "9P2000"))]) + (test "rversion-roundtrip" + (and (= (p9-message-type msg) p9-type-rversion) + (= (p9-rversion-rec-msize msg) 4096) + (string=? (p9-rversion-rec-version msg) "9P2000")) + #t)) + +;;; ========== Tauth / Rauth ========== + +(printf "~%== Auth ==~%") + +(let ([msg (roundtrip (make-p9-tauth 5 100 "glenda" ""))]) + (test "tauth-roundtrip-type" (p9-message-type msg) p9-type-tauth) + (test "tauth-afid" (p9-tauth-rec-afid msg) 100) + (test "tauth-uname" (p9-tauth-rec-uname msg) "glenda") + (test "tauth-aname" (p9-tauth-rec-aname msg) "")) + +(let* ([qid (make-p9-qid #x80 1 12345)] + [msg (roundtrip (make-p9-rauth 5 qid))]) + (test "rauth-roundtrip-type" (p9-message-type msg) p9-type-rauth) + (test "rauth-qid" + (qid=? (p9-rauth-rec-aqid msg) qid) + #t)) + +;;; ========== Tattach / Rattach ========== + +(printf "~%== Attach ==~%") + +(let ([msg (roundtrip (make-p9-tattach 1 0 #xFFFFFFFF "glenda" "/"))]) + (test "tattach-type" (p9-message-type msg) p9-type-tattach) + (test "tattach-fid" (p9-tattach-rec-fid msg) 0) + (test "tattach-afid" (p9-tattach-rec-afid msg) #xFFFFFFFF) + (test "tattach-uname" (p9-tattach-rec-uname msg) "glenda") + (test "tattach-aname" (p9-tattach-rec-aname msg) "/")) + +(let* ([qid (make-p9-qid #x80 0 99)] + [msg (roundtrip (make-p9-rattach 1 qid))]) + (test "rattach-type" (p9-message-type msg) p9-type-rattach) + (test "rattach-qid" + (qid=? (p9-rattach-rec-qid msg) qid) + #t)) + +;;; ========== Rerror ========== + +(printf "~%== Error ==~%") + +(let ([msg (roundtrip (make-p9-rerror 3 "file not found"))]) + (test "rerror-type" (p9-message-type msg) p9-type-rerror) + (test "rerror-ename" (p9-rerror-rec-ename msg) "file not found")) + +;;; ========== Twalk / Rwalk ========== + +(printf "~%== Walk ==~%") + +(let ([msg (roundtrip (make-p9-twalk 7 0 1 '("usr" "glenda" "lib")))]) + (test "twalk-type" (p9-message-type msg) p9-type-twalk) + (test "twalk-fid" (p9-twalk-rec-fid msg) 0) + (test "twalk-newfid" (p9-twalk-rec-newfid msg) 1) + (test "twalk-wnames" (p9-twalk-rec-wnames msg) '("usr" "glenda" "lib")) + (test "twalk-wname-count" (length (p9-twalk-rec-wnames msg)) 3)) + +;; Walk with empty path (clone fid) +(let ([msg (roundtrip (make-p9-twalk 8 5 6 '()))]) + (test "twalk-empty" (p9-twalk-rec-wnames msg) '())) + +;; Walk with single element +(let ([msg (roundtrip (make-p9-twalk 9 0 2 '("bin")))]) + (test "twalk-single" (p9-twalk-rec-wnames msg) '("bin"))) + +(let* ([q1 (make-p9-qid #x80 0 100)] + [q2 (make-p9-qid #x80 0 200)] + [q3 (make-p9-qid 0 0 300)] + [msg (roundtrip (make-p9-rwalk 7 (list q1 q2 q3)))]) + (test "rwalk-type" (p9-message-type msg) p9-type-rwalk) + (test "rwalk-qid-count" (length (p9-rwalk-rec-qids msg)) 3) + (test "rwalk-qid-1" + (qid=? (car (p9-rwalk-rec-qids msg)) q1) #t) + (test "rwalk-qid-3" + (qid=? (caddr (p9-rwalk-rec-qids msg)) q3) #t)) + +;; Empty Rwalk (no qids) +(let ([msg (roundtrip (make-p9-rwalk 10 '()))]) + (test "rwalk-empty" (p9-rwalk-rec-qids msg) '())) + +;;; ========== Topen / Ropen ========== + +(printf "~%== Open ==~%") + +(let ([msg (roundtrip (make-p9-topen 11 5 0))]) ;; mode=0 = OREAD + (test "topen-type" (p9-message-type msg) p9-type-topen) + (test "topen-fid" (p9-topen-rec-fid msg) 5) + (test "topen-mode" (p9-topen-rec-mode msg) 0)) + +(let* ([qid (make-p9-qid 0 3 555)] + [msg (roundtrip (make-p9-ropen 11 qid 8168))]) + (test "ropen-type" (p9-message-type msg) p9-type-ropen) + (test "ropen-qid" (qid=? (p9-ropen-rec-qid msg) qid) #t) + (test "ropen-iounit" (p9-ropen-rec-iounit msg) 8168)) + +;;; ========== Tcreate / Rcreate ========== + +(printf "~%== Create ==~%") + +(let ([msg (roundtrip (make-p9-tcreate 12 5 "hello.txt" #o0644 1))]) ;; mode=1 = OWRITE + (test "tcreate-type" (p9-message-type msg) p9-type-tcreate) + (test "tcreate-fid" (p9-tcreate-rec-fid msg) 5) + (test "tcreate-name" (p9-tcreate-rec-name msg) "hello.txt") + (test "tcreate-perm" (p9-tcreate-rec-perm msg) #o0644) + (test "tcreate-mode" (p9-tcreate-rec-mode msg) 1)) + +(let* ([qid (make-p9-qid 0 1 777)] + [msg (roundtrip (make-p9-rcreate 12 qid 8168))]) + (test "rcreate-type" (p9-message-type msg) p9-type-rcreate) + (test "rcreate-qid" (qid=? (p9-rcreate-rec-qid msg) qid) #t) + (test "rcreate-iounit" (p9-rcreate-rec-iounit msg) 8168)) + +;;; ========== Tread / Rread ========== + +(printf "~%== Read ==~%") + +(let ([msg (roundtrip (make-p9-tread 13 5 0 4096))]) + (test "tread-type" (p9-message-type msg) p9-type-tread) + (test "tread-fid" (p9-tread-rec-fid msg) 5) + (test "tread-offset" (p9-tread-rec-offset msg) 0) + (test "tread-count" (p9-tread-rec-count msg) 4096)) + +;; Read with large offset +(let ([msg (roundtrip (make-p9-tread 14 5 #x100000000 1024))]) + (test "tread-large-offset" (p9-tread-rec-offset msg) #x100000000)) + +;; Rread with data payload +(let* ([data (string->utf8 "Hello, Plan 9!")] + [msg (roundtrip (make-p9-rread 13 data))]) + (test "rread-type" (p9-message-type msg) p9-type-rread) + (test "rread-data" + (utf8->string (p9-rread-rec-data msg)) + "Hello, Plan 9!")) + +;; Rread with empty data +(let ([msg (roundtrip (make-p9-rread 15 (make-bytevector 0)))]) + (test "rread-empty" (bytevector-length (p9-rread-rec-data msg)) 0)) + +;; Rread with binary data +(let* ([data (u8-list->bytevector '(0 1 2 255 254 253 128))] + [msg (roundtrip (make-p9-rread 16 data))]) + (test "rread-binary" + (bytevector->u8-list (p9-rread-rec-data msg)) + '(0 1 2 255 254 253 128))) + +;;; ========== Twrite / Rwrite ========== + +(printf "~%== Write ==~%") + +(let* ([data (string->utf8 "Hello from client")] + [msg (roundtrip (make-p9-twrite 17 5 100 data))]) + (test "twrite-type" (p9-message-type msg) p9-type-twrite) + (test "twrite-fid" (p9-twrite-rec-fid msg) 5) + (test "twrite-offset" (p9-twrite-rec-offset msg) 100) + (test "twrite-data" + (utf8->string (p9-twrite-rec-data msg)) + "Hello from client")) + +(let ([msg (roundtrip (make-p9-rwrite 17 512))]) + (test "rwrite-type" (p9-message-type msg) p9-type-rwrite) + (test "rwrite-count" (p9-rwrite-rec-count msg) 512)) + +;;; ========== Tclunk / Rclunk ========== + +(printf "~%== Clunk ==~%") + +(let ([msg (roundtrip (make-p9-tclunk 18 5))]) + (test "tclunk-type" (p9-message-type msg) p9-type-tclunk) + (test "tclunk-fid" (p9-tclunk-rec-fid msg) 5)) + +(let ([msg (roundtrip (make-p9-rclunk 18))]) + (test "rclunk-type" (p9-message-type msg) p9-type-rclunk) + (test "rclunk-tag" (p9-message-tag msg) 18)) + +;;; ========== Tstat / Rstat ========== + +(printf "~%== Stat ==~%") + +(let ([msg (roundtrip (make-p9-tstat 19 5))]) + (test "tstat-type" (p9-message-type msg) p9-type-tstat) + (test "tstat-fid" (p9-tstat-rec-fid msg) 5)) + +(let* ([qid (make-p9-qid 0 1 42)] + [st (make-p9-stat 0 0 qid #o0644 1000000 1000001 4096 + "hello.txt" "glenda" "glenda" "glenda")] + [msg (roundtrip (make-p9-rstat 19 st))]) + (test "rstat-type" (p9-message-type msg) p9-type-rstat) + (let ([s (p9-rstat-rec-stat msg)]) + (test "rstat-name" (p9-stat-name s) "hello.txt") + (test "rstat-uid" (p9-stat-uid s) "glenda") + (test "rstat-gid" (p9-stat-gid s) "glenda") + (test "rstat-muid" (p9-stat-muid s) "glenda") + (test "rstat-mode" (p9-stat-mode s) #o0644) + (test "rstat-length" (p9-stat-length s) 4096) + (test "rstat-atime" (p9-stat-atime s) 1000000) + (test "rstat-mtime" (p9-stat-mtime s) 1000001) + (test "rstat-qid" (qid=? (p9-stat-qid s) qid) #t))) + +;;; ========== Version negotiation scenario ========== + +(printf "~%== Version negotiation scenario ==~%") + +;; Client sends Tversion, server responds with Rversion +(let* ([client-msg (make-p9-tversion #xFFFF 8192 "9P2000")] + [wire (p9-encode client-msg)] + [server-sees (p9-decode wire)]) + (test "negotiate-client-type" (p9-message-type server-sees) p9-type-tversion) + (test "negotiate-client-msize" (p9-tversion-rec-msize server-sees) 8192) + (test "negotiate-client-version" (p9-tversion-rec-version server-sees) "9P2000") + ;; Server responds + (let* ([server-msg (make-p9-rversion #xFFFF 4096 "9P2000")] + [wire2 (p9-encode server-msg)] + [client-sees (p9-decode wire2)]) + (test "negotiate-server-type" (p9-message-type client-sees) p9-type-rversion) + (test "negotiate-server-msize" (p9-rversion-rec-msize client-sees) 4096) + (test "negotiate-server-version" (p9-rversion-rec-version client-sees) "9P2000"))) + +;;; ========== Multi-element walk scenario ========== + +(printf "~%== Walk scenario ==~%") + +;; Walk /usr/glenda/lib/profile +(let* ([walk-msg (make-p9-twalk 1 0 1 '("usr" "glenda" "lib" "profile"))] + [wire (p9-encode walk-msg)] + [decoded (p9-decode wire)]) + (test "walk-scenario-count" (length (p9-twalk-rec-wnames decoded)) 4) + (test "walk-scenario-first" (car (p9-twalk-rec-wnames decoded)) "usr") + (test "walk-scenario-last" (list-ref (p9-twalk-rec-wnames decoded) 3) "profile")) + +;;; ========== UTF-8 string handling ========== + +(printf "~%== UTF-8 ==~%") + +;; Error message with non-ASCII characters +(let ([msg (roundtrip (make-p9-rerror 20 "permission denied: \x3BB;"))]) + (test "utf8-error" (p9-rerror-rec-ename msg) "permission denied: \x3BB;")) + +;;; ========== Summary ========== + +(printf "~%--- Results: ~a passed, ~a failed ---~%" pass fail) +(when (> fail 0) (exit 1))