9p-server work so far (big patch for the curious) added by alaricsp on Tue Apr 24 00:00:56 2012
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"))