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

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

9: factored out virtual filesystem from demo server.

File size: 14.4 KB
Line 
1;;; 9p-server-vfs.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 a higher-level infrastructure on top of
7;; 9p-server, implementing a simplistic virtual filesystem.
8;;
9;; It's not very complete at the moment.
10;
11; Copyright (c) 2012, Alaric Snell-Pym
12; All rights reserved.
13;
14; Redistribution and use in source and binary forms, with or without
15; modification, are permitted provided that the following conditions
16; are met:
17;
18; 1. Redistributions of source code must retain the above copyright
19;    notice, this list of conditions and the following disclaimer.
20; 2. Redistributions in binary form must reproduce the above copyright
21;    notice, this list of conditions and the following disclaimer in the
22;    documentation and/or other materials provided with the distribution.
23; 3. Neither the name of the author nor the names of its
24;    contributors may be used to endorse or promote products derived
25;    from this software without specific prior written permission.
26;
27; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
28; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
29; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
30; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
31; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
32; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
33; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
34; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
35; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
36; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
37; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
38; OF THE POSSIBILITY OF SUCH DAMAGE.
39;
40; Please report bugs, suggestions and ideas to the Chicken Trac
41; ticket tracking system (assign tickets to user 'alaric'):
42; http://trac.callcc.org
43
44(require-library 9p-lolevel 9p-server srfi-1 srfi-4 srfi-69)
45
46(module 9p-server-vfs
47        (new-filesystem
48         insert-file! insert-static-file! insert-simple-file!
49         insert-directory!
50         vfs-serve)
51
52(import chicken
53        scheme
54        9p-lolevel
55        9p-server
56        srfi-1
57        srfi-4
58        srfi-69)
59
60(define-record file
61  type
62  id
63  name
64  perms
65  uname
66  gname
67  muname
68  size-if-known ; if #f, get-contents will be called and the result measured
69  atime
70  mtime
71  get-contents ; Closure that returns a u8vector, blob or string, given the file object and the Open State
72  parent-id ; Parent directory ID
73  children ; List of child file objects
74  handle-open! ; returns a new Open State
75  handle-clunk! ; passed an Open State
76  )
77
78(define-record-printer (file f out)
79  (fprintf out "#<file ~s: ~s>"
80           (file-id f)
81           (file-name f)))
82
83(define (file-qid file)
84  (make-qid (file-type file) 1 (file-id file)))
85
86(define (file-stat file)
87  (list (file-qid file)
88        (bitwise-ior (file-perms file) (arithmetic-shift (file-type file) 24))
89        (file-atime file)
90        (file-mtime file)
91        (file-size file)
92        (file-name file)
93        (file-uname file)
94        (file-gname file)
95        (file-muname file)))
96
97(define (file-contents file user-state)
98  (let ((c ((file-get-contents file) file user-state)))
99    (cond
100     ((u8vector? c) c)
101     ((string? c) (blob->u8vector/shared (string->blob c)))
102     ((blob? c) (blob->u8vector/shared c))
103     (else (error "Invalid file contents" c)))))
104
105(define (file-size file)
106  (if (zero? (bitwise-and (file-type file) qtdir))
107   (if (file-size-if-known file)
108       (file-size-if-known file)
109       (u8vector-length (file-contents file #f)))
110   0)) ; Directories must report zero size
111
112(define-record filesystem
113  files
114  file-id-counter
115  logging?)
116
117(define-record directory-reader
118  last-offset
119  remaining-entries)
120
121(define (new-filesystem root-perms root-uname root-gname root-atime root-mtime logging?)
122  (let ((fs (make-filesystem (make-hash-table) 1 logging?)))
123    (hash-table-set! (filesystem-files fs) 0
124                     (make-file
125                      qtdir
126                      0
127                      "/"
128                      root-perms
129                      root-uname
130                      root-gname
131                      root-uname
132                      #f
133                      root-atime
134                      root-mtime
135                      #f ; Directories never have their contents asked for
136                      #f
137                      '()
138                      (lambda (file) (make-directory-reader 0 (map file-stat (file-children file))))
139                      (lambda (file state) (void))))
140    fs))
141
142
143;; FIXME: Add some specialised insert-file!s
144;; Eg, in this case, we can have an insert-static-file! that just has a string/blob/u8vector
145;; contents set at creation and a known size.
146;;
147;; And we can have an insert-simple-file! that has a callback called on open that
148;; returns the file's contents as the state and reads are handled from that, with
149;; the option of returning a hardcoded size or handling a stat as an anonymous
150;; open.
151;;
152;; And we can have support for writable files, such as append-only files
153;; that call a callback on each write, single-write files that call a callback
154;; on close with the entire written content, etc.
155
156(define (insert-file! filesystem type name perms uname gname muname size-if-known atime mtime get-contents parent-id handle-open! handle-clunk!)
157  (let* ((id (filesystem-file-id-counter filesystem))
158         (f (make-file type id name perms uname gname muname size-if-known atime mtime get-contents parent-id '() handle-open! handle-clunk!))
159         (parent-dir (if parent-id
160                         (hash-table-ref (filesystem-files filesystem) parent-id)
161                         #f)))
162    (filesystem-file-id-counter-set! filesystem (+ id 1))
163    (hash-table-set! (filesystem-files filesystem) id f)
164    (when parent-dir
165          (let* ((old-children (file-children parent-dir))
166                 (new-children (cons f old-children)))
167            (file-children-set! parent-dir new-children)))
168    id))
169
170(define (insert-directory! filesystem name perms uname gname muname atime mtime parent-id)
171  (insert-file! filesystem
172                qtdir
173                name perms uname gname muname #f atime mtime
174                #f
175                parent-id
176                (lambda (file)
177                  (make-directory-reader 0 (map file-stat (file-children file))))
178                (lambda (file state) (void))))
179
180;; Contents is a constant value
181(define (insert-static-file! filesystem name perms uname gname muname atime mtime contents parent-id)
182  (insert-file! filesystem
183                qtfile
184                name perms uname gname muname
185                #f
186                atime mtime
187                (lambda (file state) contents)
188                parent-id
189                (lambda (file) #f)
190                (lambda (file state) (void))))
191
192;; Contents is a thunk called when the file is opened
193(define (insert-simple-file! filesystem name perms uname gname muname atime mtime contents parent-id)
194  (insert-file! filesystem
195                qtfile
196                name perms uname gname muname
197                #f
198                atime mtime
199                (lambda (file state) (if state state (contents)))
200                parent-id
201                (lambda (file) (contents))
202                (lambda (file state) (void))))
203
204;; FIXME: Add remove-file!, insert-directory!, remove-directory!, etc.
205
206(define (filesystem-file filesystem id)
207  (hash-table-ref (filesystem-files filesystem) id))
208
209(define (filesystem-root filesystem)
210  (filesystem-file filesystem 0))
211
212(define (filesystem-walk filesystem parent-dir name)
213  (call-with-current-continuation
214   (lambda (return)
215     (let ((dirlist (file-children parent-dir)))
216       (if (list? dirlist)
217           (for-each (lambda (file)
218                       (when (string=? (file-name file) name)
219                             (return file)))
220                     dirlist)
221           #f) ;; #f not a directory
222       #f)))) ;; #f not found
223
224;; 9P2000
225
226(define-record file-open
227  file
228  contents
229  user-state)
230
231(define-record-printer (file-open fo out)
232  (fprintf out "#<file-open ~s/~s>"
233           (file-open-file fo)
234           (file-open-user-state fo)))
235
236(define +block-size+ 16384)
237
238(define (dump-message filesystem Ttype message)
239  (when (filesystem-logging? filesystem)
240        (printf "~S: ~S\n" Ttype message)))
241
242(define (dump-message-fid filesystem Ttype message fid-value)
243  (when (filesystem-logging? filesystem)
244        (printf "~S: ~S ~S\n" Ttype message fid-value)))
245
246(define ((handle-version filesystem) message)
247  (dump-message filesystem 'Tversion message)
248  (min +block-size+ (car message)))
249
250(define ((handle-auth filesystem) message bind-fid! reply! error!)
251  (dump-message filesystem 'Tauth message)
252  (error! "You don't need to authenticate with me.")
253  (void))
254
255(define ((handle-flush filesystem) message reply! error!)
256  (dump-message filesystem 'Tflush message)
257  (reply! '())
258  (void))
259
260(define ((handle-attach filesystem) message auth-fid-value bind-fid! reply! error!)
261  (dump-message-fid filesystem 'Tattach message auth-fid-value)
262  (let ((root (filesystem-root filesystem)))
263   (bind-fid! (make-file-open root #f #f))
264   (reply! (list (file-qid root)))))
265
266(define ((handle-walk filesystem) message parent-fid-value bind-fid! reply! error!)
267  (dump-message-fid filesystem 'Twalk message parent-fid-value)
268  (let loop ((names (caddr message))
269             (parent (file-open-file parent-fid-value))
270             (qids '()))
271    (cond
272     ((null? names)
273      (bind-fid! (make-file-open parent #f #f))
274      (reply! (list (reverse qids))))
275     (else
276      (let* ((name (car names))
277             (child (filesystem-walk filesystem parent name)))
278        (if child
279            (loop (cdr names)
280                  child
281                  (cons (file-qid child) qids))
282            (begin ;; Nonexistant child, stop here
283              (if (null? qids)
284                  (error! "Unknown filename")
285                  (reply! (list (reverse qids)))))))))))
286
287(define ((handle-open filesystem) message fid-value reply! error!)
288  (dump-message-fid filesystem 'Topen message fid-value)
289  (let* ((file (file-open-file fid-value))
290         (user-state ((file-handle-open! file) file)))
291    (file-open-user-state-set! fid-value user-state)
292    (if (eq? (file-type file) qtdir)
293     (file-open-contents-set! fid-value #f)
294     (file-open-contents-set! fid-value (file-contents file user-state)))
295    (reply! (list (file-qid file) +block-size+))))
296
297(define ((handle-create filesystem) message fid-value reply! error!)
298  (dump-message-fid filesystem 'Tcreate message fid-value)
299  (error! "Not yet implemented"))
300
301(define (handle-file-read filesystem message fid-value reply! error!)
302  (let* ((file (file-open-file fid-value))
303         (contents (file-open-contents fid-value))
304         (offset (second message))
305         (count (min (- (u8vector-length contents) offset)
306                     (third message))))
307    (reply! (list
308             (subu8vector contents offset (+ offset count))))))
309
310(define (handle-dir-read filesystem message fid-value reply! error!)
311  (let* ((file (file-open-file fid-value))
312         (reader (file-open-user-state fid-value))
313         (previous-offset (directory-reader-last-offset
314                           reader))
315         (offset (second message))
316         (remaining-entries
317          (if (zero? offset)
318              (map file-stat (file-children file))
319              (directory-reader-remaining-entries
320               reader)))
321         (count (third message)))
322    (if ;; Enforce rules about directory reads - they must be sequential
323     (not (or
324           (= previous-offset offset)
325           (= offset 0)))
326     (error! "Directory reads must be from the previous offset or back to 0")
327     (begin
328       ;; Return as many whole stat entries as can be packed into a read
329       ;; without leaving any partials
330       ;; Each stat entry is prefixed with its length in bytes, so we can
331       ;; skip thruogh the chain easily.
332       (receive (response new-remaining-entries)
333                (full-directory-listing->data
334                 remaining-entries count)
335                (directory-reader-last-offset-set!
336                 reader (+ offset (u8vector-length response)))
337                (directory-reader-remaining-entries-set!
338                 reader new-remaining-entries)
339                (reply! (list response)))))))
340
341(define ((handle-read filesystem) message fid-value reply! error!)
342  (dump-message-fid filesystem 'Tread message fid-value)
343  (let ((file (file-open-file fid-value)))
344    (if (eq? (file-type file)
345             qtdir)
346        (handle-dir-read filesystem message fid-value reply! error!)
347        (handle-file-read filesystem message fid-value reply! error!))))
348
349(define ((handle-write filesystem) message fid-value reply! error!)
350  (dump-message-fid filesystem 'Twrite message fid-value)
351  (error! "Not yet implemented"))
352
353(define ((handle-clunk filesystem) fid-value reply! error!)
354  (dump-message-fid filesystem 'Tclunk '() fid-value)
355  (let ((file (file-open-file fid-value))
356        (user-state (file-open-user-state fid-value)))
357    ((file-handle-clunk! file) file user-state))
358  (reply! '()))
359
360(define ((handle-remove filesystem) fid-value reply! error!)
361  (dump-message-fid filesystem 'Tremove '() fid-value)
362  (error! "Not yet implemented"))
363
364(define ((handle-stat filesystem) message fid-value reply! error!)
365  (dump-message-fid filesystem 'Tstat message fid-value)
366  (reply! (file-stat (file-open-file fid-value))))
367
368(define ((handle-wstat filesystem) message fid-value reply! error!)
369  (dump-message-fid filesystem 'Twstat message fid-value)
370  (error! "Not yet implemented"))
371
372(define ((handle-disconnect filesystem))
373  (if (filesystem-logging? filesystem) (printf "Disconnected\n")))
374
375(define (vfs-serve in out filesystem)
376  (serve in out
377         `((version . ,(handle-version filesystem))
378           (auth . ,(handle-auth filesystem))
379           (flush . ,(handle-flush filesystem))
380           (attach . ,(handle-attach filesystem))
381           (walk . ,(handle-walk filesystem))
382           (open . ,(handle-open filesystem))
383           (create . ,(handle-create filesystem))
384           (read . ,(handle-read filesystem))
385           (write . ,(handle-write filesystem))
386           (clunk . ,(handle-clunk filesystem))
387           (remove . ,(handle-remove filesystem))
388           (stat . ,(handle-stat filesystem))
389           (wstat . ,(handle-wstat filesystem))
390           (disconnect . ,(handle-disconnect filesystem)))))
391
392)
Note: See TracBrowser for help on using the repository browser.