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"))