misc 9p changes added by evhan on Mon Apr 23 18:18:08 2012
Index: 9p.setup
===================================================================
--- 9p.setup (revision 25314)
+++ 9p.setup (working copy)
@@ -4,9 +4,17 @@
(compile -s -O2 9p-client.scm -j 9p-client)
(compile -s -O2 9p-client.import.scm)
+(compile -s -O2 9p-server.scm -j 9p-server)
+(compile -s -O2 9p-server.import.scm)
+
+(compile -s -O2 9p-fs.scm -j 9p-fs)
+(compile -s -O2 9p-fs.import.scm)
+
(install-extension
'9p
'("9p-lolevel.so" "9p-lolevel.import.so"
- "9p-client.so" "9p-client.import.so")
+ "9p-client.so" "9p-client.import.so"
+ "9p-server.so" "9p-server.import.so"
+ "9p-fs.so" "9p-fs.import.so")
`((version 0.8)
(documentation "9p.html")))
Index: 9p-lolevel.scm
===================================================================
--- 9p-lolevel.scm (revision 25314)
+++ 9p-lolevel.scm (working copy)
@@ -164,6 +164,23 @@
(u8vector-set! v (- size i) (inexact->exact (modulo num 256))) ; XXX
(loop (sub1 i) (quotient num 256)))))))
+;; XXX copied & pasted from 9p-client
+(define (u8vector-append! . vectors)
+ (let* ((length (apply + (map u8vector-length vectors)))
+ (result (make-u8vector length)))
+ (let next-vector ((vectors vectors)
+ (result-pos 0))
+ (if (null? vectors)
+ result
+ (let next-pos ((vector-pos 0)
+ (result-pos result-pos))
+ (if (= vector-pos (u8vector-length (car vectors)))
+ (next-vector (cdr vectors) result-pos)
+ (begin
+ (u8vector-set! result result-pos
+ (u8vector-ref (car vectors) vector-pos))
+ (next-pos (add1 vector-pos) (add1 result-pos)))))))))
+
(define (u8vector-slice v start length)
(subu8vector v start (+ start length)))
@@ -188,8 +205,8 @@
(flush-output port))
;; Total size of all u8vectors in this packet (as a u8vector)
-(define (packet-size len packet)
- (number->u8vector len (fold (lambda (v total) (+ total (u8vector-length v))) len packet)))
+(define (packet-size packet)
+ (reduce + 0 (map u8vector-length packet)))
;; Create a 'message format error' condition.
;; This condition signals a protocol violation
@@ -206,55 +223,74 @@
;; Return value is a list of u8vectors that encode this argument.
(define (pack-argument message-type type arg)
(if (and (list? type) (null? (cdr type))) ; If cdr isn't null, it's malformed
- (begin
- ;; This code is rather ugly and over-specialized. It's only necessary
- ;; for the Twalk/Rwalk message types because only those need list types
- (if (list? arg)
- (let ((result (apply append (map (lambda (entry) (pack-argument message-type (car type) entry)) arg)))
- (item-size (case (car type) ((string) 2) ((qid) 3))))
- (cons (number->u8vector 2 (/ (length result) item-size)) result))
- (message-format-error message-type type arg)))
+ ;; This code is rather ugly and over-specialized. It's only necessary
+ ;; for the Twalk/Rwalk message types because only those need list types
+ (if (list? arg)
+ (let ((result (apply append (map (lambda (entry) (pack-argument message-type (car type) entry)) arg)))
+ (item-size (case (car type) ((string) 2) ((qid) 3))))
+ (cons (number->u8vector 2 (/ (length result) item-size)) result))
+ (message-format-error message-type type arg))
(case type
- ((msize fid time permission-mode datasize access-mode)
+ ((msize fid time permission-mode datasize)
(list (number->u8vector 4 arg)))
((qid)
(list (number->u8vector 1 (qid-type arg))
(number->u8vector 4 (qid-version arg))
(number->u8vector 8 (qid-path arg))))
- ((filesize) (list (number->u8vector 8 arg)))
+ ((access-mode)
+ (list (number->u8vector 1 arg)))
+ ((filesize)
+ (list (number->u8vector 8 arg)))
+ ((tag)
+ (list (number->u8vector 2 arg)))
((data)
- (list (number->u8vector 4 (u8vector-length arg)) arg))
+ (list (number->u8vector 4 (u8vector-length arg)) arg))
((string)
- (list (number->u8vector 2 (string-length arg)) (blob->u8vector/shared (string->blob arg))))
+ (list (number->u8vector 2 (string-length arg))
+ (blob->u8vector/shared (string->blob arg))))
;; Internal error
(else (error (sprintf "Unknown type: ~S, arg = ~S" type arg))))))
-(define (construct-packet code message-type tag orig-contents)
- (let loop ((template (cdr message-type))
- (contents orig-contents)
- (data (list (u8vector code) (number->u8vector 2 tag))))
- (cond
- ((null? template)
- (if (null? contents)
- (cons (packet-size 4 data) data)
- (message-format-error (car message-type) (cdr message-type) orig-contents "Too many arguments for message")))
- ((null? contents)
- (message-format-error (car message-type) (cdr message-type) orig-contents "Too few arguments for message"))
- ((eq? (car template) 'statsize) ;; Ugly exception. Continue with new list
- (let* ((rest (loop (cdr template) contents '()))
- (newpacket `(,@data ,(u8vector-slice (car rest) 0 2) ,@(cdr rest))))
- (cons (packet-size 4 newpacket) newpacket)))
- ((eq? (car template) 'dev) ;; "kernel use"
- (loop (cdr template) contents (append data (list (number->u8vector 4 0)))))
- ((eq? (car template) 'type) ;; "kernel use"
- (loop (cdr template) contents (append data (list (number->u8vector 2 0)))))
- (else
- (loop (cdr template)
- (cdr contents)
- (append data (pack-argument message-type
- (car template)
- (car contents))))))))
+(define (construct-packet code message-type tag contents)
+ (let* ((type+tag (list (u8vector code) (number->u8vector 2 tag)))
+ (packet (construct-packet-body message-type (cdr message-type) contents))
+ (data (append type+tag packet)))
+ (cons (number->u8vector 4 (+ 4 (packet-size data))) data)))
+(define (construct-packet-body message-type template contents)
+ (let loop ((template template)
+ (contents contents)
+ (data '()))
+ (cond ((null? template)
+ (if (null? contents)
+ data
+ (message-format-error
+ (car message-type) (cdr message-type)
+ contents "Too many arguments for message")))
+ ((null? contents)
+ (message-format-error
+ (car message-type) (cdr message-type)
+ contents "Too few arguments for message"))
+ (else (case (car template)
+ ((statsize) ;; Ugly exception. Continue with new list
+ (let ((rest (loop (cdr template) contents '())))
+ (cons (number->u8vector 2 (packet-size rest)) rest)))
+ ((dev) ;; "kernel use" (the mark of a well-designed spec)
+ (loop (cdr template)
+ contents
+ (append data (list (number->u8vector 4 0)))))
+ ((type) ;; "kernel use"
+ (loop (cdr template)
+ contents
+ (append data (list (number->u8vector 2 0)))))
+ (else
+ (loop (cdr template)
+ (cdr contents)
+ (append data (pack-argument
+ message-type
+ (car template)
+ (car contents))))))))))
+
(define (send-message outport message)
(receive (template code)
(find-message (message-type message))
@@ -291,15 +327,17 @@
(+ offset piece-length)
(append result piece))))))
(case type
- ((msize fid permission-mode access-mode datasize time)
+ ((msize fid permission-mode datasize time)
(values 4 (list (u8vector->number (u8vector-slice packet offset 4)))))
((qid)
(let ((mode (u8vector->number (u8vector-slice packet offset 1)))
- (version (u8vector->number (u8vector-slice packet (+ offset 1) 4)))
- (path (u8vector->number (u8vector-slice packet (+ offset 5) 8))))
- (values 13 (list (make-qid mode version path)))))
+ (version (u8vector->number (u8vector-slice packet (+ offset 1) 4)))
+ (path (u8vector->number (u8vector-slice packet (+ offset 5) 8))))
+ (values 13 (list (make-qid mode version path)))))
((filesize)
(values 8 (list (u8vector->number (u8vector-slice packet offset 8)))))
+ ((access-mode)
+ (values 1 (list (u8vector->number (u8vector-slice packet offset 1)))))
((data)
(let ((datasize (u8vector->number (u8vector-slice packet offset 4))))
(values (+ datasize 4) (list (u8vector-slice packet (+ offset 4) datasize)))))
@@ -321,27 +359,26 @@
;; Extract (tag message-type . message-contents) from a packet u8vector
(define (deconstruct-packet packet)
(let* ((code (u8vector->number (subu8vector packet 0 1)))
- (message-type (list-ref message-types (- code 100)))
- (tag (u8vector->number (subu8vector packet 1 3)))
- (packet-length (u8vector-length packet)))
+ (message-type (list-ref message-types (- code 100)))
+ (tag (u8vector->number (subu8vector packet 1 3)))
+ (packet-length (u8vector-length packet)))
(let loop ((offset 3)
- (template (cdr message-type))
- (data '()))
- (cond
- ((null? template)
- (if (= offset (u8vector-length packet))
- (make-message (car message-type) tag data)
- (message-format-error (car message-type) (cdr message-type)
- packet "Too large packet for message")))
- ((= offset packet-length)
- (message-format-error (car message-type) (cdr message-type)
- packet "Too small packet for message"))
- (else
- (receive (fragment-size contents)
- (unpack-argument (car template) packet offset)
- (loop (+ offset fragment-size)
- (cdr template)
- (append data contents))))))))
+ (template (cdr message-type))
+ (data '()))
+ (cond ((null? template)
+ (if (= offset (u8vector-length packet))
+ (make-message (car message-type) tag data)
+ (message-format-error (car message-type) (cdr message-type)
+ packet "Too large packet for message")))
+ ((= offset packet-length)
+ (message-format-error (car message-type) (cdr message-type)
+ packet "Too small packet for message"))
+ (else
+ (receive (fragment-size contents)
+ (unpack-argument (car template) packet offset)
+ (loop (+ offset fragment-size)
+ (cdr template)
+ (append data contents))))))))
(define (receive-message inport)
(let* ((packet (read-packet inport)))
@@ -369,4 +406,5 @@
(next-piece (cdr remaining-structure)
(cons contents pieces)
(+ offset fragment-size)))))))))
-)
\ No newline at end of file
+
+)
Index: 9p.meta
===================================================================
--- 9p.meta (revision 25314)
+++ 9p.meta (working copy)
@@ -1,8 +1,8 @@
((egg "9p.egg")
- (synopsis "9p networked filesystem protocol implementation. Includes high-level client code library")
+ (synopsis "9p networked filesystem protocol implementation.")
(needs iset)
(author "Peter Bex")
(category net)
(license "BSD")
(doc-from-wiki)
- (files "9p.release-info" "9p-client.scm" "9p-lolevel.scm" "9p.meta" "9p.setup"))
+ (files "9p.release-info" "9p-fs.scm" "9p-server.scm" "9p-client.scm" "9p-lolevel.scm" "9p.meta" "9p.setup"))