source: project/release/4/9p/trunk/9p-server.scm @ 27516

Last change on this file since 27516 was 27516, checked in by Alaric Snell-Pym, 9 years ago

9p: Removed debugging printfs!

File size: 16.2 KB
Line 
1;;; 9p-server.scm
2;
3;; An implementation of the Plan 9 File Protocol (9p)
4;; This egg implements the version known as 9p2000 or Styx.
5;;
6;; This file contains the apparatus required to be a Plan 9
7;; server.
8;
9; Copyright (c) 2012, Alaric Snell-Pym
10; All rights reserved.
11;
12; Redistribution and use in source and binary forms, with or without
13; modification, are permitted provided that the following conditions
14; are met:
15;
16; 1. Redistributions of source code must retain the above copyright
17;    notice, this list of conditions and the following disclaimer.
18; 2. Redistributions in binary form must reproduce the above copyright
19;    notice, this list of conditions and the following disclaimer in the
20;    documentation and/or other materials provided with the distribution.
21; 3. Neither the name of the author nor the names of its
22;    contributors may be used to endorse or promote products derived
23;    from this software without specific prior written permission.
24;
25; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
26; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
27; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
28; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
29; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
30; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
31; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
32; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
33; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
34; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
35; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
36; OF THE POSSIBILITY OF SUCH DAMAGE.
37;
38; Please report bugs, suggestions and ideas to the Chicken Trac
39; ticket tracking system (assign tickets to user 'alaric'):
40; http://trac.callcc.org
41
42(require-library srfi-18 srfi-69 9p-lolevel extras)
43
44(module 9p-server
45 (serve)
46
47 (import scheme chicken srfi-18 srfi-69 (prefix 9p-lolevel 9p:) extras)
48
49 (define session-error-message "A session has not been initiated with a Tversion request")
50
51 (define (dbg message . args)
52  ;;   (apply printf message args)
53  ;;   (newline)
54   (if (pair? args)
55       (car args)
56       (void)))
57
58 ;; This procedure calls the given callbacks when different requests
59 ;; arrive. However, you are responsible for sending responses
60 ;; yourself, beyond the special case of Tversion.
61
62 ;; Types of handlers:
63
64 ;; (handle-version message) => max-size
65 ;; (handle-auth message bind-fid! reply! error!) => <unspecified>
66 ;; (handle-flush message reply! error!) => <unspecified>
67 ;; (handle-attach message auth-fid-value bind-fid! reply! error!) => <unspecified>
68 ;; (handle-walk message parent-fid-value bind-fid! reply! error!) => <unspecified>
69 ;; (handle-open message fid-value reply! error!) => <unspecified>
70 ;; (handle-create message fid-value reply! error!) => <unspecified>
71 ;; (handle-read message fid-value reply! error!) => <unspecified>
72 ;; (handle-write message fid-value reply! error!) => <unspecified>
73 ;; (handle-clunk fid-value reply! error!) => <unspecified>
74 ;; (handle-remove fid-value reply! error!) => <unspecified>
75 ;; (handle-stat message fid-value reply! error!) => <unspecified>
76 ;; (handle-wstat message fid-value reply! error!) => <unspecified>
77
78 ;; Types used in types of handlers:
79
80 ;; message     The contents field of a 9p message (a list)
81 ;; (bind-fid! obj) => <unspecified>   Binds the given arbitrary value to the applicable fid.
82 ;; (reply! message) => <unspecified>   Sends the supplied message contents as the success response
83 ;; (error! string) => <unspecified>    Sends the supplied error message as a failure response
84
85 ;; FIXME: Add exception catching when we invoked handlers and call
86 ;;  error! with the exn message rather than leaving the request dangling.
87
88 (define (serve-9p2000 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)
89   (let* ((fids-mutex (make-mutex))
90          (fids (make-hash-table))
91          (lookup-fid (lambda (fid)
92                        (dynamic-wind
93                            (lambda () (mutex-lock! fids-mutex))
94                            (lambda () (hash-table-ref/default fids fid #f))
95                            (lambda () (mutex-unlock! fids-mutex)))))
96          (bind-fid! (lambda (fid value)
97                       (dbg "Binding ~S to fid ~S" value fid)
98                       (dynamic-wind
99                           (lambda () (mutex-lock! fids-mutex))
100                           (lambda () (hash-table-set! fids fid value))
101                           (lambda () (mutex-unlock! fids-mutex)))
102                       (void)))
103          (clunk-fid! (lambda (fid)
104                        (dbg "Clunking fid ~S" fid)
105                        (dynamic-wind
106                            (lambda () (mutex-lock! fids-mutex))
107                            (lambda () (hash-table-delete! fids fid))
108                            (lambda () (mutex-unlock! fids-mutex)))
109                        (void)))
110          (outport-mutex (make-mutex))
111          (send-message! (lambda (msg)
112                           (dbg "Sending message ~S/~S/~S"
113                                (9p:message-type msg)
114                                (9p:message-tag msg)
115                                (9p:message-contents msg))
116                           (dynamic-wind
117                               (lambda () (mutex-lock! outport-mutex))
118                               (lambda ()
119                                 (9p:send-message outport msg)
120                                 (flush-output outport))
121                               (lambda () (mutex-unlock! outport-mutex)))
122                           (void)))
123          (send-error! (lambda (msg error)
124                        (send-message!
125                         (9p:make-message 'Rerror
126                                          (9p:message-tag msg)
127                                          (list error)))))
128          (call-standard-handler
129           ;; This calls a handler that involves no FIDs
130           (lambda (handler message Rtype)
131             (handler (9p:message-contents message)
132                      (lambda (reply)
133                        (send-message!
134                         (9p:make-message Rtype (9p:message-tag message) reply)))
135                      (lambda (error)
136                        (send-error! message error)))))
137          (call-fiddly-handler
138           ;; This calls a handler that binds a FID supplied as the
139           ;; first argument in the message
140           (lambda (handler message Rtype)
141             (let ((fid (car (9p:message-contents message))))
142               (handler (9p:message-contents message)
143                        (lambda (val) (bind-fid! fid val))
144                        (lambda (reply)
145                          (send-message!
146                           (9p:make-message Rtype (9p:message-tag message) reply)))
147                        (lambda (error)
148                          (send-error! message error))))))
149          (call-fid-using-handler
150           ;; This calls a handler that has an existing FID as the first
151           ;; argument in the message
152           (lambda (handler message Rtype)
153             (let ((fid (car (9p:message-contents message))))
154               (handler (9p:message-contents message)
155                        (lookup-fid fid)
156                        (lambda (reply)
157                          (send-message!
158                           (9p:make-message Rtype (9p:message-tag message) reply)))
159                        (lambda (error)
160                          (send-error! message error)))))))
161     (let loop ((session-started? #f))
162       (dbg "Waiting for message")
163       (let ((message (9p:receive-message inport)))
164         (if (eof-object? message)
165             (handle-disconnect)
166             (begin
167              (dbg "Received a message ~S/~S/~S"
168                   (9p:message-type message)
169                   (9p:message-tag message)
170                   (9p:message-contents message))
171              (case (9p:message-type message)
172                ((Tversion)
173                 (let ((max-size (min
174                                  (car (9p:message-contents message))
175                                  (handle-version (9p:message-contents message)))))
176                   (send-message!
177                    (9p:make-message 'Rversion (9p:message-tag message) (list max-size "9P2000")))
178                   (loop #t)))
179                ((Tauth)
180                 (if session-started?
181                     (call-fiddly-handler handle-auth message 'Rauth)
182                     (send-error! message session-error-message))
183                 (loop session-started?))
184                ((Tflush)
185                 (if session-started?
186                     (call-standard-handler handle-flush message 'Rflush)
187                     (send-error! message session-error-message))
188                 (loop session-started?))
189                ((Tattach)
190                 (if session-started?
191                     (let ((root-fid (car (9p:message-contents message)))
192                           (auth-fid (cadr (9p:message-contents message))))
193                       (handle-attach (9p:message-contents message)
194                                      (lookup-fid auth-fid)
195                                      (lambda (val) (bind-fid! root-fid val))
196                                      (lambda (reply)
197                                        (send-message!
198                                         (9p:make-message 'Rattach (9p:message-tag message) reply)))
199                                      (lambda (error)
200                                        (send-error! message error))))
201                     (send-error! message session-error-message))
202                 (loop session-started?))
203                ((Twalk)
204                 (if session-started?
205                     (let ((parent-fid (car (9p:message-contents message)))
206                           (child-fid (cadr (9p:message-contents message))))
207                       (handle-walk (9p:message-contents message)
208                                    (lookup-fid parent-fid)
209                                    (lambda (val) (bind-fid! child-fid val))
210                                    (lambda (reply)
211                                      (send-message!
212                                       (9p:make-message 'Rwalk (9p:message-tag message) reply)))
213                                    (lambda (error)
214                                      (send-error! message error))))
215                     (send-error! message session-error-message))
216                 (loop session-started?))
217                ((Topen)
218                 (if session-started?
219                     (call-fid-using-handler handle-open message 'Ropen)
220                     (send-error! message session-error-message))
221                 (loop session-started?))
222                ((Tcreate)
223                 (if session-started?
224                     (call-fid-using-handler handle-create message 'Rcreate)
225                     (send-error! message session-error-message))
226                 (loop session-started?))
227                ((Tread)
228                 (if session-started?
229                     (call-fid-using-handler handle-read message 'Rread)
230                     (send-error! message session-error-message))
231                 (loop session-started?))
232                ((Twrite)
233                 (if session-started?
234                     (call-fid-using-handler handle-write message 'Rwrite)
235                     (send-error! message session-error-message))
236                 (loop session-started?))
237                ((Tclunk)
238                 (if session-started?
239                     (let* ((fid (car (9p:message-contents message)))
240                            (fid-value (lookup-fid fid)))
241                       (clunk-fid! fid)
242                       (handle-clunk
243                        fid-value
244                        (lambda (reply)
245                          (send-message!
246                           (9p:make-message 'Rclunk (9p:message-tag message) reply)))
247                        (lambda (error)
248                          (send-error! message error))))
249                     (send-error! message session-error-message))
250                 (loop session-started?))
251                ((Tremove)
252                 (if session-started?
253                     (let* ((fid (car (9p:message-contents message)))
254                            (fid-value (lookup-fid fid)))
255                       (handle-remove
256                        fid-value
257                        (lambda (reply)
258                          (send-message!
259                           (9p:make-message 'Rremove (9p:message-tag message) reply)))
260                        (lambda (error)
261                          (send-error! message error))))
262                     (send-error! message session-error-message))
263                 (loop session-started?))
264                ((Tstat)
265                 (if session-started?
266                     (call-fid-using-handler handle-stat message 'Rstat)
267                     (send-error! message session-error-message))
268                 (loop session-started?))
269                ((Twstat)
270                 (if session-started?
271                     (call-fid-using-handler handle-wstat message 'Rwstat)
272                     (send-error! message session-error-message))
273                 (loop session-started?)))))))))
274
275
276 (define (serve inport outport handlers)
277   (let ((assq* (lambda (obj a-list)
278                  (let ((elem (assq obj a-list)))
279                    (if elem
280                        (cdr elem)
281                        #f)))))
282     (let ((handle-version (or (assq* 'version handlers)
283                               (lambda (message) (car message))))
284           (handle-auth (or (assq* 'auth handlers)
285                            (lambda (message bind-fid! reply! error!)
286                              (error! "Authentication is not supported"))))
287           (handle-flush (or (assq* 'flush handlers)
288                             (lambda (message reply! error!)
289                               (reply! '()))))
290           (handle-attach (or (assq* 'attach handlers)
291                              (error "attach must be implemented")))
292           (handle-walk (or (assq* 'walk handlers)
293                            (error "walk must be implemented")))
294           (handle-open (or (assq* 'open handlers)
295                            (error "open must be implemented")))
296           (handle-create (or (assq* 'create handlers)
297                              (lambda (message fid-value reply! error!)
298                                (error! "Creating objects is not supported"))))
299           (handle-read (or (assq* 'read handlers)
300                            (lambda (message fid-value reply! error!)
301                              (error! "Reading is not supported"))))
302           (handle-write (or (assq* 'write handlers)
303                             (lambda (message fid-value reply! error!)
304                               (error! "Writing is not supported"))))
305           (handle-clunk (or (assq* 'clunk handlers)
306                             (lambda (fid-value reply! error!)
307                               (reply! '()))))
308           (handle-remove (or (assq* 'remove handlers)
309                              (lambda (fid-value reply! error!)
310                                (error! "Removing objects is not supported"))))
311           (handle-stat (or (assq* 'stat handlers)
312                            (lambda (message fid-value reply! error!)
313                              (error! "Stat is not supported"))))
314           (handle-wstat (or (assq* 'wstat handlers)
315                             (lambda (message fid-value reply! error!)
316                               (error! "Wstat is not supported"))))
317           (handle-disconnect (or (assq* 'disconnect handlers)
318                                  (lambda ()
319                                    (void)))))
320
321       (serve-9p2000 inport outport
322                     handle-version handle-auth handle-flush
323                     handle-attach handle-walk handle-open
324                     handle-create handle-read handle-write
325                     handle-clunk handle-remove handle-stat
326                     handle-wstat handle-disconnect))))
327)
Note: See TracBrowser for help on using the repository browser.