Index: 9p.setup =================================================================== --- 9p.setup (revision 26560) +++ 9p.setup (working copy) @@ -4,9 +4,13 @@ (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) + (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") `((version 0.8) (documentation "9p.html"))) Index: 9p-demo-server.scm =================================================================== --- 9p-demo-server.scm (revision 0) +++ 9p-demo-server.scm (working copy) @@ -0,0 +1,251 @@ +(use 9p-server 9p-lolevel tcp) + +(define (dump-message Ttype message) + (printf "~S: ~S\n" Ttype message)) + +(define (dump-message-fid Ttype message fid-value) + (printf "~S: ~S ~S\n" Ttype message fid-value)) + +(define-record file + type + id + name + perms + uname + gname + muname + size-if-known + atime + mtime + get-contents + parent-id) + +(define (file-qid file) + (make-qid (file-type file) 1 (file-id file))) + +(define (file-stat file) + `(,(file-qid file) + ,(bitwise-ior (file-perms file) (arithmetic-shift (file-type file) 24)) + ,(file-atime file) + ,(file-mtime file) + ,(file-size file) + ,(file-name file) + ,(file-uname file) + ,(file-gname file) + ,(file-muname file))) + +(define (file-contents file) + (let ((c ((file-get-contents file) file))) + (cond + ((u8vector? c) c) + ((string? c) (blob->u8vector/shared (string->blob c))) + ((blob? c) (blob->u8vector/shared c)) + ((list? c) (full-directory-listing->data + (map file-stat c))) + (else (error "Invalid file contents"))))) + +(define (file-size file) + (if (zero? (bitwise-and (file-type file) qtdir)) + (if (file-size-if-known file) + (file-size-if-known file) + (u8vector-length (file-contents file))) + 0)) ; Directories must report zero size + +(define-record filesystem + files + file-id-counter) + +;; FIXME: Put a list of children of each directory in the filesystem object +;; rather than scanning the entire beast. +(define (directory-get-contents filesystem dir-id) + (hash-table-fold (filesystem-files filesystem) + (lambda (id file results) + (if (and (file-parent-id file) (= dir-id (file-parent-id file))) + (cons file results) + results)) + '())) + +(define (new-filesystem root-perms root-uname root-gname root-atime root-mtime) + (let ((fs (make-filesystem (make-hash-table) 1))) + (hash-table-set! (filesystem-files fs) 0 + (make-file + qtdir + 0 + "/" + root-perms + root-uname + root-gname + root-uname + #f + root-atime + root-mtime + (lambda (file) (directory-get-contents fs 0)) + #f)) + fs)) + +(define (insert-file! filesystem type name perms uname gname muname size-if-known atime mtime get-contents parent-id) + (let* ((id (filesystem-file-id-counter filesystem)) + (f (make-file type id name perms uname gname muname size-if-known atime mtime get-contents parent-id))) + (filesystem-file-id-counter-set! filesystem (+ id 1)) + (hash-table-set! (filesystem-files filesystem) id f) + f)) + +(define (filesystem-file filesystem id) + (hash-table-ref (filesystem-files filesystem) id)) + +(define (filesystem-root filesystem) + (filesystem-file filesystem 0)) + +(define (filesystem-walk filesystem parent-dir name) + (call-with-current-continuation + (lambda (return) + (let ((dirlist ((file-get-contents parent-dir) parent-dir))) + (if (list? dirlist) + (for-each (lambda (file) + (when (string=? (file-name file) name) + (return file))) + dirlist) + #f) ;; #f not a directory + #f)))) ;; #f not found + +;; A static filesystem (for now) + +(define filesystem (new-filesystem + (+ perm/irusr perm/ixusr perm/irgrp perm/ixgrp perm/iroth perm/ixoth) + "root" + "root" + 0 + 0)) + +(insert-file! filesystem + qtfile + "hello" + (+ perm/irusr perm/irgrp perm/iroth) + "root" + "root" + "root" + #f + 0 + 0 + (lambda (file) "Hello, world!\n") + 0) + +(insert-file! filesystem + qtfile + "test" + (+ perm/irusr perm/irgrp perm/iroth) + "root" + "root" + "root" + #f + 0 + 0 + (lambda (file) "Hello, again!\n") + 0) + +;; 9P2000 + +(define +block-size+ 16384) + +(define (handle-version message) + (dump-message 'Tversion message) + (min +block-size+ (car message))) + +(define (handle-auth message bind-fid! reply! error!) + (dump-message 'Tauth message) + (error! "You don't need to authenticate with me.") + (void)) + +(define (handle-flush message reply! error!) + (dump-message 'Tflush message) + (reply! '()) + (void)) + +(define (handle-attach message auth-fid-value bind-fid! reply! error!) + (dump-message-fid 'Tattach message auth-fid-value) + (let ((root (filesystem-root filesystem))) + (bind-fid! root) + (reply! (list (file-qid root))))) + +(define (handle-walk message parent-fid-value bind-fid! reply! error!) + (dump-message-fid 'Twalk message parent-fid-value) + (let loop ((names (cddr message)) + (parent parent-fid-value) + (qids '())) + (cond + ((null? names) + (bind-fid! parent) + (reply! (list (reverse qids)))) + (else + (let* ((name (car names)) + (child (filesystem-walk filesystem parent name))) + (if child + (loop (cdr names) + child + (cons (file-qid child) qids)) + (begin ;; Nonexistant child, stop here + (if (null? qids) + (error! "Unknown filename") + (reply! (list (reverse qids))))))))))) + +(define (handle-open message fid-value reply! error!) + (dump-message-fid 'Topen message fid-value) + ;; FIXME: Check permissions, and have a hashtable in the filesystem + ;; that maps a (session, file id) pair to an open-state in which to store + ;; anything we need, and expose it to extra per-file handlers. + (reply! (list (file-qid fid-value) +block-size+))) + +(define (handle-create message fid-value reply! error!) + (dump-message-fid 'Tcreate message fid-value) + ;; FIXME: Check permissions. + (error! "Not yet implemented")) + +(define (handle-read message fid-value reply! error!) + (dump-message-fid 'Tread message fid-value) + (let* ((contents (file-contents fid-value)) + (offset (second message)) + (count (min (- (u8vector-length contents) offset) + (third message)))) + (reply! (list + (subu8vector contents offset (+ offset count)))))) + +(define (handle-write message fid-value reply! error!) + (dump-message-fid 'Twrite message fid-value) + (error! "Not yet implemented")) + +(define (handle-clunk fid-value reply! error!) + (dump-message-fid 'Tclunk '() fid-value) + (reply! '())) + +(define (handle-remove fid-value reply! error!) + (dump-message-fid 'Tremove '() fid-value) + (error! "Not yet implemented")) + +(define (handle-stat message fid-value reply! error!) + (dump-message-fid 'Tstat message fid-value) + (reply! (file-stat fid-value))) + +(define (handle-wstat message fid-value reply! error!) + (dump-message-fid 'Twstat message fid-value) + (error! "Not yet implemented")) + +(define (handle-disconnect) + (printf "Disconnected\n")) + +(parameterize ((tcp-read-timeout #f) + (tcp-buffer-size 65536)) + (let ((listener (tcp-listen 564))) + (let accept-loop () + (receive (in out) (tcp-accept listener) + (printf "New connection!\n") + (thread-start! (make-thread + (lambda () + (serve in out + handle-version handle-auth handle-flush + handle-attach handle-walk handle-open + handle-create handle-read handle-write + handle-clunk handle-remove handle-stat + handle-wstat handle-disconnect) + (close-input-port in) + (close-output-port out))))) + (accept-loop)))) \ No newline at end of file Index: 9p-lolevel.scm =================================================================== --- 9p-lolevel.scm (revision 26560) +++ 9p-lolevel.scm (working copy) @@ -44,7 +44,7 @@ ;; Perhaps a dyn-vector can be used instead of lists of u8vectors. ;; Possibly this is more efficient. -(require-library srfi-1 srfi-4) +(require-library srfi-1 srfi-4 lolevel) (module 9p-lolevel (qid? make-qid qid-type qid-version qid-path @@ -58,9 +58,10 @@ notag nofid stat-keep-number stat-keep-string message? make-message message-type message-tag message-contents send-message receive-message data->directory-listing + data->full-directory-listing full-directory-listing->data message-type-set! message-contents-set! message-tag-set!) -(import scheme chicken srfi-1 srfi-4 extras) +(import scheme chicken srfi-1 srfi-4 extras lolevel) (define-record qid type version path) @@ -88,15 +89,15 @@ (define dmdir #x80000000) ; Is a directory (define dmappend #x40000000) ; Append-only (define dmexcl #x20000000) ; Exclusive use -; #x08000000 is skipped "for historical reasons" -(define dmauth #x04000000) ; Authentication file (established by auth messages) -(define dmtmp #x02000000) ; Temporary file +; #x10000000 is skipped "for historical reasons" +(define dmauth #x08000000) ; Authentication file (established by auth messages) +(define dmtmp #x04000000) ; Temporary file (define qtfile #x00) ; Don't check for this! (define qtdir #x80) (define qtappend #x40) (define qtexcl #x20) -; #x08 is skipped "for historical reasons" +; #x10 is skipped "for historical reasons" (define qtauth #x08) (define qttmp #x04) @@ -191,6 +192,9 @@ (define (packet-size len packet) (number->u8vector len (fold (lambda (v total) (+ total (u8vector-length v))) len packet))) +(define (stat-size len packet) + (number->u8vector len (fold (lambda (v total) (+ total (u8vector-length v))) 0 packet))) + ;; Create a 'message format error' condition. ;; This condition signals a protocol violation (define (message-format-error message-type expected actual . rest) @@ -215,7 +219,9 @@ (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) + ((access-mode) + (list (number->u8vector 1 arg))) + ((msize fid time permission-mode datasize) (list (number->u8vector 4 arg))) ((qid) (list (number->u8vector 1 (qid-type arg)) @@ -229,21 +235,20 @@ ;; 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)) +(define (unparse-packet message-type orig-template orig-contents) + (let loop ((template orig-template) (contents orig-contents) - (data (list (u8vector code) (number->u8vector 2 tag)))) + (data (list))) (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"))) + data + (message-format-error message-type orig-template 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")) + (message-format-error message-type orig-template 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))) + (let* ((rest (loop (cdr template) contents data))) + (cons (stat-size 2 rest) rest))) ((eq? (car template) 'dev) ;; "kernel use" (loop (cdr template) contents (append data (list (number->u8vector 4 0))))) ((eq? (car template) 'type) ;; "kernel use" @@ -255,6 +260,14 @@ (car template) (car contents)))))))) +(define (construct-packet code message-type tag contents) + (let* ((template (cdr message-type)) + (body (unparse-packet (car message-type) template contents)) + (data (append (list (u8vector code) (number->u8vector 2 tag)) body)) + (size (packet-size 4 data))) + (printf "DEBUG: ~S ~S\n" size data) + (cons size data))) + (define (send-message outport message) (receive (template code) (find-message (message-type message)) @@ -271,7 +284,9 @@ (define (read-packet port) (let ((size (u8vector->number (read-u8vector 4 port)))) - (read-u8vector (- size 4) port))) + (if (< size 4) + #!eof + (read-u8vector (- size 4) port)))) ;; Unpack an argument from the network and make something useful out ;; of it (a list of stuff and the length of the stuff parsed) @@ -291,7 +306,9 @@ (+ offset piece-length) (append result piece)))))) (case type - ((msize fid permission-mode access-mode datasize time) + ((access-mode) + (values 1 (list (u8vector->number (u8vector-slice packet offset 1))))) + ((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))) @@ -318,55 +335,86 @@ (error (sprintf "Unknown type: ~A, packet = ~S, offset = ~A" type packet offset)))))) +(define (parse-data packet offset length type orig-template) + (let loop ((offset offset) + (template orig-template) + (data '())) + (cond + ((null? template) + (if (or (not length) (= offset length)) + (values offset data) + (message-format-error type orig-template + packet "Too large packet for message"))) + ((and length (= offset length)) + (message-format-error type orig-template + 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))))))) + ;; 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))) - (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)))))))) + (receive (offset packet-contents) (parse-data packet 3 packet-length (car message-type) (cdr message-type)) + (make-message (car message-type) tag packet-contents)))) (define (receive-message inport) (let* ((packet (read-packet inport))) - (deconstruct-packet packet))) + (if (eof-object? packet) + #!eof + (deconstruct-packet packet)))) ;; Ugly hack needed because READ is overloaded to return structured ;; data if we're reading a dir -(define (data->directory-listing data show-dotfiles?) +(define (data->full-directory-listing data show-dotfiles?) (receive (message-structure num) (find-message 'Rstat) (let next-entry ((entries (list)) (offset 0)) (if (= offset (u8vector-length data)) entries - (let next-piece ((remaining-structure (cddr message-structure)) - (pieces (list)) - (offset offset)) - (if (null? remaining-structure) - (let ((entry (car (list-ref pieces 3)))) ; Filename - (if (and (not show-dotfiles?) (char=? (string-ref entry 0) #\.)) - (next-entry entries offset) - (next-entry (cons entry entries) offset))) - (receive (fragment-size contents) - (unpack-argument (car remaining-structure) data offset) - (next-piece (cdr remaining-structure) - (cons contents pieces) - (+ offset fragment-size))))))))) + (receive (new-offset entry) (parse-data data offset #f 'Rstat (cddr message-structure)) + (let ((name (list-ref entry 5))) + (printf "DEBUG: ~S ~S\n" entry name) + (if (and (not show-dotfiles?) (char=? (string-ref name 0) #\.)) + (next-entry entries new-offset) + (next-entry (cons entry entries) new-offset)))))))) + +(define (data->directory-listing data show-dotfiles?) + (map (lambda (entry) (list-ref entry 5)) + (data->full-directory-listing data show-dotfiles?))) + +(define (flatten-u8vector vl) + (let* ((len (fold (lambda (v acc) + (+ acc (u8vector-length v))) + 0 + vl)) + (vec (make-u8vector len))) + (let loop ((offset 0) + (vl vl)) + (if (null? vl) + vec + (begin + (move-memory! (car vl) vec + (u8vector-length (car vl)) + 0 offset) + (loop (+ offset (u8vector-length (car vl))) + (cdr vl))))))) + +(define (full-directory-listing->data dir) + (receive (message-structure num) + (find-message 'Rstat) + (let next-entry ((data (list)) + (dir dir)) + (if (null? dir) + (flatten-u8vector data) + (let ((entry (unparse-packet 'Rstat (cddr message-structure) (car dir)))) + (next-entry (append entry data) (cdr dir))))))) + ) \ No newline at end of file Index: 9p-server.scm =================================================================== --- 9p-server.scm (revision 0) +++ 9p-server.scm (working copy) @@ -0,0 +1,274 @@ +;;; 9p-server.scm +; +;; An implementation of the Plan 9 File Protocol (9p) +;; This egg implements the version known as 9p2000 or Styx. +;; +;; This file contains the apparatus required to be a Plan 9 +;; server. +; +; Copyright (c) 2012, Alaric Snell-Pym +; All rights reserved. +; +; Redistribution and use in source and binary forms, with or without +; modification, are permitted provided that the following conditions +; are met: +; +; 1. Redistributions of source code must retain the above copyright +; notice, this list of conditions and the following disclaimer. +; 2. Redistributions in binary form must reproduce the above copyright +; notice, this list of conditions and the following disclaimer in the +; documentation and/or other materials provided with the distribution. +; 3. Neither the name of the author nor the names of its +; contributors may be used to endorse or promote products derived +; from this software without specific prior written permission. +; +; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +; OF THE POSSIBILITY OF SUCH DAMAGE. +; +; Please report bugs, suggestions and ideas to the Chicken Trac +; ticket tracking system (assign tickets to user 'alaric'): +; http://trac.callcc.org + +(require-library srfi-18 srfi-69 9p-lolevel extras) + +(module 9p-server + (serve) + + (import scheme chicken srfi-18 srfi-69 (prefix 9p-lolevel 9p:) extras) + + (define session-error-message "A session has not been initiated with a Tversion request") + + (define (dbg message . args) + (apply printf message args) + (newline) + (if (pair? args) + (car args) + (void))) + + ;; This procedure calls the given callbacks when different requests + ;; arrive. However, you are responsible for sending responses + ;; yourself, beyond the special case of Tversion. + + ;; Types of handlers: + + ;; (handle-version message) => max-size + ;; (handle-auth message bind-fid! reply! error!) => + ;; (handle-flush message reply! error!) => + ;; (handle-attach message auth-fid-value bind-fid! reply! error!) => + ;; (handle-walk message parent-fid-value bind-fid! reply! error!) => + ;; (handle-open message fid-value reply! error!) => + ;; (handle-create message fid-value reply! error!) => + ;; (handle-read message fid-value reply! error!) => + ;; (handle-write message fid-value reply! error!) => + ;; (handle-clunk fid-value reply! error!) => + ;; (handle-remove fid-value reply! error!) => + ;; (handle-stat message fid-value reply! error!) => + ;; (handle-wstat message fid-value reply! error!) => + + ;; Types used in types of handlers: + + ;; message The contents field of a 9p message (a list) + ;; (bind-fid! obj) => Binds the given arbitrary value to the applicable fid. + ;; (reply! message) => Sends the supplied message contents as the success response + ;; (error! string) => Sends the supplied error message as a failure response + + ;; FIXME: Add exception catching when we invoked handlers and call + ;; error! with the exn message rather than leaving the request dangling. + + (define (serve inport outport handle-version handle-auth handle-flush handle-attach handle-walk handle-open handle-create handle-read handle-write handle-clunk handle-remove handle-stat handle-wstat handle-disconnect) + (let* ((fids-mutex (make-mutex)) + (fids (make-hash-table)) + (lookup-fid (lambda (fid) + (dynamic-wind + (lambda () (mutex-lock! fids-mutex)) + (lambda () (hash-table-ref/default fids fid #f)) + (lambda () (mutex-unlock! fids-mutex))))) + (bind-fid! (lambda (fid value) + (dbg "Binding ~S to fid ~S" value fid) + (dynamic-wind + (lambda () (mutex-lock! fids-mutex)) + (lambda () (hash-table-set! fids fid value)) + (lambda () (mutex-unlock! fids-mutex))) + (void))) + (clunk-fid! (lambda (fid) + (dbg "Clunking fid ~S" fid) + (dynamic-wind + (lambda () (mutex-lock! fids-mutex)) + (lambda () (hash-table-delete! fids fid)) + (lambda () (mutex-unlock! fids-mutex))) + (void))) + (outport-mutex (make-mutex)) + (send-message! (lambda (msg) + (dbg "Sending message ~S/~S/~S" + (9p:message-type msg) + (9p:message-tag msg) + (9p:message-contents msg)) + (dynamic-wind + (lambda () (mutex-lock! outport-mutex)) + (lambda () + (9p:send-message outport msg) + (flush-output outport)) + (lambda () (mutex-unlock! outport-mutex))) + (void))) + (send-error! (lambda (msg error) + (send-message! + (9p:make-message 'Rerror + (9p:message-tag msg) + (list error))))) + (call-standard-handler + ;; This calls a handler that involves no FIDs + (lambda (handler message Rtype) + (handler (9p:message-contents message) + (lambda (reply) + (send-message! + (9p:make-message Rtype (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error))))) + (call-fiddly-handler + ;; This calls a handler that binds a FID supplied as the + ;; first argument in the message + (lambda (handler message Rtype) + (let ((fid (car (9p:message-contents message)))) + (handler (9p:message-contents message) + (lambda (val) (bind-fid! fid val)) + (lambda (reply) + (send-message! + (9p:make-message Rtype (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error)))))) + (call-fid-using-handler + ;; This calls a handler that has an existing FID as the first + ;; argument in the message + (lambda (handler message Rtype) + (let ((fid (car (9p:message-contents message)))) + (handler (9p:message-contents message) + (lookup-fid fid) + (lambda (reply) + (send-message! + (9p:make-message Rtype (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error))))))) + (let loop ((session-started? #f)) + (dbg "Waiting for message") + (let ((message (9p:receive-message inport))) + (if (eof-object? message) + (handle-disconnect) + (begin + (dbg "Received a message ~S/~S/~S" + (9p:message-type message) + (9p:message-tag message) + (9p:message-contents message)) + (case (9p:message-type message) + ((Tversion) + (let ((max-size (min + (car (9p:message-contents message)) + (handle-version (9p:message-contents message))))) + (send-message! + (9p:make-message 'Rversion (9p:message-tag message) (list max-size "9P2000"))) + (loop #t))) + ((Tauth) + (if session-started? + (call-fiddly-handler handle-auth message 'Rauth) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tflush) + (if session-started? + (call-standard-handler handle-flush message 'Rflush) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tattach) + (if session-started? + (let ((root-fid (car (9p:message-contents message))) + (auth-fid (cadr (9p:message-contents message)))) + (handle-attach (9p:message-contents message) + (lookup-fid auth-fid) + (lambda (val) (bind-fid! root-fid val)) + (lambda (reply) + (send-message! + (9p:make-message 'Rattach (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error)))) + (send-error! message session-error-message)) + (loop session-started?)) + ((Twalk) + (if session-started? + (let ((parent-fid (car (9p:message-contents message))) + (child-fid (cadr (9p:message-contents message)))) + (handle-walk (9p:message-contents message) + (lookup-fid parent-fid) + (lambda (val) (bind-fid! child-fid val)) + (lambda (reply) + (send-message! + (9p:make-message 'Rwalk (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error)))) + (send-error! message session-error-message)) + (loop session-started?)) + ((Topen) + (if session-started? + (call-fid-using-handler handle-open message 'Ropen) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tcreate) + (if session-started? + (call-fid-using-handler handle-create message 'Rcreate) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tread) + (if session-started? + (call-fid-using-handler handle-read message 'Rread) + (send-error! message session-error-message)) + (loop session-started?)) + ((Twrite) + (if session-started? + (call-fid-using-handler handle-write message 'Rwrite) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tclunk) + (if session-started? + (let* ((fid (car (9p:message-contents message))) + (fid-value (lookup-fid fid))) + (clunk-fid! fid) + (handle-clunk + fid-value + (lambda (reply) + (send-message! + (9p:make-message 'Rclunk (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error)))) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tremove) + (if session-started? + (let* ((fid (car (9p:message-contents message))) + (fid-value (lookup-fid fid))) + (handle-remove + fid-value + (lambda (reply) + (send-message! + (9p:make-message 'Rremove (9p:message-tag message) reply))) + (lambda (error) + (send-error! message error)))) + (send-error! message session-error-message)) + (loop session-started?)) + ((Tstat) + (if session-started? + (call-fid-using-handler handle-stat message 'Rstat) + (send-error! message session-error-message)) + (loop session-started?)) + ((Twstat) + (if session-started? + (call-fid-using-handler handle-wstat message 'Rwstat) + (send-error! message session-error-message)) + (loop session-started?))))))))) +) \ No newline at end of file Index: 9p.meta =================================================================== --- 9p.meta (revision 26560) +++ 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. Includes high-level client and server code library") (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-client.scm" "9p-server.scm" "9p-lolevel.scm" "9p.meta" "9p.setup"))