source: project/release/3/9p/trunk/9p-client.scm @ 8067

Last change on this file since 8067 was 8067, checked in by sjamaan, 12 years ago

Add TODO note about 9p:rename-file to the top
Add some blob stuff to 9p:file-read to circumvent possible utf8 usage and document why we did this
Remove utf8 from lolevel egg (user is expected to make the tradeoff to use utf8 or not)

File size: 17.4 KB
Line 
1;;;; 9p.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 posix-like higher-level client-side abstraction over
7;; the lower-level connection and message packing/unpacking provided by 9p-lolevel.
8;
9; Copyright (c) 2007, Peter Bex
10; All rights reserved.
11;
12; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
13; conditions are met:
14;
15;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
16;     disclaimer.
17;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
18;     disclaimer in the documentation and/or other materials provided with the distribution.
19;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
20;     products derived from this software without specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
23; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
24; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
25; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
29; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30; POSSIBILITY OF SUCH DAMAGE.
31;
32; Please report bugs, suggestions and ideas to the Chicken Trac
33; ticket tracking system (assign tickets to user 'sjamaan'):
34; http://trac.callcc.org
35;
36; TODO: 9p:rename-file.  Unfortunately, 9p has no native 'move' command, so
37; this will be hard and very error-prone to do, at least in the case of directories.
38; Something for another time :)
39
40(use 9p-lolevel srfi-13 iset)
41
42(define-record 9p:connection
43  inport outport message-size open-fids)
44
45(define (9p:server-error message-type error-message)
46  (signal
47   (make-composite-condition
48    (make-property-condition 'exn 'message (sprintf "9p server returned ~S for message ~A" error-message message-type))
49    (make-property-condition '9p-server-error 'message-type message-type))))
50
51(define (9p:response-error message-type response-type)
52  (signal
53   (make-composite-condition
54    (make-property-condition 'exn 'message (sprintf "9p server returned unexpected response type ~S for message ~A" response-type message-type))
55    (make-property-condition '9p-response-error 'message-type message-type))))
56
57;; Client request.  Sends a message of the given type and args and waits
58;; for a matching response (a Rxyz response matches a Txyz request).
59(define (9p:request con type . args)
60  ;; Always use a tag of 1
61  (9p:send-message (9p:connection-outport con) (make-9p:message type 1 args))
62  (let ((response (9p:receive-message (9p:connection-inport con)))
63        (expected-type (string->symbol (string-replace (symbol->string type) "R" 0 1))))
64    (cond
65     ((eq? (9p:message-type response) expected-type)
66      response)
67     ((eq? (9p:message-type response) 'Rerror)
68      (9p:server-error type (car (9p:message-contents response))))
69     (else
70      (9p:response-error type (9p:message-type response))))))
71
72;; Initialize a connection to a 9p server ("mount"/"bind")
73;; Authentication is currently not supported
74(define (9p:client-connect inport outport . rest)
75  (let-optionals rest ((user "")
76                       (mountpoint ""))
77    (let* ((bv (make-bit-vector 8))  ; Start out with 8 bits.  Let it grow only when needed
78           (con (make-9p:connection inport outport #xffffffff bv))
79            ; We can handle message size #xffffffff but wmii/libixp crashes on that. #x7ffffff is the absolute max for it
80           (answer (9p:request con 'Tversion #x7fffffff "9P2000")))
81      (cond
82       ((not (string=? "9P2000" (cadr (9p:message-contents answer))))
83        (error (sprintf "Incompatible protocol version: ~S" (9p:message-contents answer))))
84       (else
85        (9p:connection-message-size-set! con (car (9p:message-contents answer)))
86        ;; To authenticate, do a Tauth request, authenticate and use the fid we got
87        ;; when authenticating instead of nofid below.
88        ;;
89        ;; Allocate the root fid using alloc-handle so we automatically get a finalizer set
90        (9p:request con 'Tattach (9p:handle-fid (9p:alloc-handle con)) nofid user mountpoint)
91        con)))))
92
93;; Sever connection, clunk all fids
94(define (9p:client-disconnect con)
95  (let ((fids (9p:connection-open-fids con)))
96    (let loop ((fid (bit-vector-length fids)))
97      (when (not (zero? fid))
98        (when (bit-vector-ref fids (sub1 fid))
99          (9p:file-close (make-9p:handle con (sub1 fid) 0 #f)))
100        (loop (sub1 fid))))))
101
102;; File IDs and handles
103(define-record 9p:handle
104  connection fid position iounit)
105
106(define (9p:initialize-iounit! h iounit)
107  (9p:handle-iounit-set!
108   h
109   (if (zero? iounit)
110       ;; 23 is the biggest size of a message (write), but libixp uses 24, so we do too to stay safe
111       (- (9p:connection-message-size (9p:handle-connection h)) 24)
112       iounit)))
113
114;; Allocate the lowest fid that's not in use yet and return a handle to it
115(define (9p:alloc-handle con)
116  (let loop ((fids (9p:connection-open-fids con))
117             (highest 0))
118    (cond
119     ((bit-vector-full? fids (add1 highest))
120      (loop fids (add1 highest)))
121     ((>= highest nofid)
122      (error "Out of file ids"))
123     (else
124      (9p:connection-open-fids-set! con (bit-vector-set! fids highest #t))
125      (make-9p:handle con highest 0 #f)))))
126
127;; Deallocate the given handle from the list (does _not_ clunk it)
128(define (9p:release-handle h)
129  (9p:connection-open-fids-set! (9p:handle-connection h) (bit-vector-set! (9p:connection-open-fids (9p:handle-connection h)) (9p:handle-fid h) #f))
130  ;; Invalidate the handle
131  (9p:handle-connection-set! h #f)
132  (9p:handle-fid-set! h #f)
133  (9p:handle-iounit-set! h #f)
134  (void))
135
136;; Make a list of path components.  Accepts either a string which it will split
137;; at slashes, or a pre-made path component list.
138(define (9p:normalize-path path)
139  (if (pair? path)
140      path
141      (string-split path "/")))
142
143;; Obtain a new fid
144(define (9p:path-walk con path . rest)
145  (let-optionals rest ((starting-point 0))
146    (let ((new-handle (9p:alloc-handle con)))
147      (handle-exceptions exn (begin (9p:release-handle new-handle) (signal exn))
148       (9p:message-contents (9p:request con 'Twalk starting-point (9p:handle-fid new-handle) (9p:normalize-path path)))
149       new-handle))))
150
151;; Clunk a fid
152(define (9p:file-close h)
153  (when (9p:handle-connection h) ; Ignore invalid handles (if already closed, closing again is ok)
154   (9p:request (9p:handle-connection h) 'Tclunk (9p:handle-fid h))
155   (9p:release-handle h)))
156
157;; With a temporary handle to a file, perform some other procedure
158;; The handle gets walked to and clunked automatically
159(define (9p:with-handle-to con path procedure)
160  (let ((h (9p:path-walk con path)))
161    (handle-exceptions
162     exn
163     (begin
164       (9p:file-close h)
165       (signal exn)) ;; Just reraise it
166     (let ((result (call-with-values (lambda () (procedure h)) list)))
167       (9p:file-close h)
168       (apply values result)))))
169
170;; This is a hack, as the server might return other errors beside "file does not exist",
171;; but there's no way we can really ask this question otherwise.
172(define (9p:file-exists? con path)
173  (condition-case (9p:with-handle-to con path (constantly #t))
174    ((exn 9p-server-error) #f)))
175
176(define (9p:file-open con name mode)
177  (let* ((h (9p:path-walk con name))
178         (response (9p:request con 'Topen (9p:handle-fid h) mode))
179         (iounit (second (9p:message-contents response))))
180    (9p:initialize-iounit! h iounit)
181    h))
182
183;; This duplicates much of with-handle-to, but 9p isn't very consistent here: the
184;; fid that initially represents the directory is now reused and represents the
185;; newly created file, so we can't use with-handle-to (or we'd have to reopen the
186;; file after creating, which is not possible in case of tempfiles)
187(define (9p:file-create con name perm mode)
188  (let ((h (9p:path-walk con (pathname-directory name))))
189    (handle-exceptions
190     exn
191     (begin
192       (9p:file-close h)
193       (signal exn)) ;; Just reraise it
194     (let* ((response (9p:request con 'Tcreate (9p:handle-fid h) (pathname-strip-directory name) perm mode))
195            (iounit (second (9p:message-contents response))))
196       (9p:initialize-iounit! h iounit)
197       h))))
198
199(define (u8vector-append! . vectors)
200  (let* ((length (apply + (map u8vector-length vectors)))
201         (result (make-u8vector length)))
202    (let next-vector ((vectors vectors)
203                      (result-pos 0))
204      (if (null? vectors)
205          result
206          (let next-pos ((vector-pos 0)
207                         (result-pos result-pos))
208            (if (= vector-pos (u8vector-length (car vectors)))
209                (next-vector (cdr vectors) result-pos)
210                (begin
211                  (u8vector-set! result result-pos (u8vector-ref (car vectors) vector-pos))
212                  (next-pos (add1 vector-pos) (add1 result-pos)))))))))
213
214;; TODO: Find a way to use an optional buffer to write in, so we don't end up
215;; copying a whole lot of data around (overhead!)  -- file-write also has this
216;; This is doubly bad because if we have a small message size the copying and
217;; appending really becomes a whole lot of overhead.
218(define (9p:file-read h size)
219  (let loop ((bytes-left size)
220             (total 0)
221             (result (list)))
222    (if (zero? bytes-left)
223        (list (blob->string (u8vector->blob/shared (apply u8vector-append! (reverse result)))) total) ; file-read also returns a list of data + length
224        (let* ((pos (9p:handle-position h))
225               (receive-size (min bytes-left (9p:handle-iounit h)))
226               (response (9p:request (9p:handle-connection h) 'Tread (9p:handle-fid h) pos receive-size))
227               (data (car (9p:message-contents response)))
228               (read (u8vector-length data)))
229          (cond
230           ((zero? read)
231            (loop 0 total (cons (make-u8vector bytes-left (char->integer #\space)) result))) ; Pad with empty u8vector, just like file-read
232           ((> read bytes-left) ; Sometimes the server returns more than we asked for! (when accidentally reading a dir, for example)
233            (9p:handle-position-set! h (+ pos bytes-left))
234            (loop 0 (+ total bytes-left) (cons (u8vector-slice data 0 bytes-left) result)))
235           (else
236            (9p:handle-position-set! h (+ pos read))
237            (loop (- bytes-left read) (+ total read) (cons data result))))))))
238
239(define (9p:file-write h buffer . rest)
240  (let ((buffer (if (string? buffer)
241                    (blob->u8vector/shared (string->blob buffer))
242                    buffer)))
243    (let-optionals rest ((size (u8vector-length buffer)))
244      (let loop ((bytes-left size)
245                 (total 0))
246        (if (zero? bytes-left)
247            total
248            (let* ((pos (9p:handle-position h))
249                   (send-size (min bytes-left (9p:handle-iounit h)))
250                   (response (9p:request (9p:handle-connection h) 'Twrite (9p:handle-fid h) pos (u8vector-slice buffer total send-size)))
251                   (written (car (9p:message-contents response))))
252              (9p:handle-position-set! h (+ pos written))
253              (if (not (= written send-size))
254                  (9p:server-error 'Twrite (sprintf "Unexpected bytecount ~A instead of ~A in Rwrite response (not a proper server error message)" written send-size)))
255              (loop (- bytes-left written) (+ total written))))))))
256
257; (qid permission-mode time time filesize string string string string)
258(define (9p:handle-stat h)
259  (apply values (9p:message-contents (9p:request (9p:handle-connection h) 'Tstat (9p:handle-fid h)))))
260
261(define (9p:file-stat con file)
262  (9p:with-handle-to
263   con file 9p:handle-stat))
264
265(define (9p:file-permissions con file)
266  (call-with-values
267      (lambda () (9p:file-stat con file))
268    (lambda l (list-ref l 1))))
269
270(define (9p:file-access-time con file)
271  (call-with-values
272      (lambda () (9p:file-stat con file))
273    (lambda l (list-ref l 2))))
274
275(define (9p:file-modification-time con file)
276  (call-with-values
277      (lambda () (9p:file-stat con file))
278    (lambda l (list-ref l 3))))
279
280;; There is no file-change-time because the protocol does not provide it.
281
282(define (9p:file-size con file)
283  (call-with-values
284      (lambda () (9p:file-stat con file))
285    (lambda l (list-ref l 4))))
286
287;; 5 is file-name, which is rather silly
288
289;;; Important: The following three procedures return _strings_, not IDs
290(define (9p:file-owner con file)
291  (call-with-values
292      (lambda () (9p:file-stat con file))
293    (lambda l (list-ref l 6))))
294
295(define (9p:file-group con file)
296  (call-with-values
297      (lambda () (9p:file-stat con file))
298    (lambda l (list-ref l 7))))
299
300(define (9p:file-last-modified-by con file)
301  (call-with-values
302      (lambda () (9p:file-stat con file))
303    (lambda l (list-ref l 8))))
304
305(define (9p:directory? con file)
306  (call-with-values
307      (lambda () (9p:file-stat con file))
308    (lambda l (not (zero? (bitwise-and 9p:dmdir (list-ref l 1)))))))
309
310;; TODO: Find out if this is enough.  9p supports no symlinks?
311(define (9p:regular-file? con file)
312  (not (9p:directory? con file)))
313
314(define (9p:set-file-position! h pos . rest)
315  (let-optionals rest ((whence seek/set))
316    (cond
317     ((< 0 pos) (signal (make-composite-condition
318                         (make-property-condition 'exn 'message (sprintf "Invalid negative seek position: ~S" pos))
319                         (make-property-condition 'bounds))))
320     ((eq? whence seek/set)
321      (9p:handle-position-set! h pos))
322     ((eq? whence seek/cur)
323      (9p:handle-position-set! h (+ (9p:handle-position h) pos)))
324     ((eq? whence seek/end)
325      (let ((size (call-with-values
326                      (lambda () (9p:handle-stat h))
327                    (lambda l (list-ref 4)))))
328        ((9p:handle-position-set! h (+ size pos)))))
329     (else (error (sprintf "Unknown seek position type (WHENCE value): ~S" whence))))))
330
331(define 9p:file-position 9p:handle-position)
332
333(define (9p:directory con file . rest)
334  (let-optionals rest ((show-dotfiles? #f))
335   (9p:with-handle-to
336    con file
337    (lambda (h)
338      (call-with-values
339          (lambda () (9p:handle-stat h))
340        (lambda l
341          (if (zero? (bitwise-and 9p:dmdir (list-ref l 1)))
342              (signal (make-composite-condition
343                       (make-property-condition 'exn 'message (sprintf "~S is not a directory!" file))
344                       (make-property-condition 'file)))
345              (let* ((response (9p:request con 'Topen (9p:handle-fid h) 9p:open/rdonly))
346                     (iounit (second (9p:message-contents response))))
347                (9p:initialize-iounit! h iounit)
348                (9p:read-directory h show-dotfiles?)))))))))
349
350(define (9p:delete-file con path)
351  (let ((h (9p:path-walk con path)))
352    (handle-exceptions exn (begin (9p:release-handle h) (signal exn))
353      (9p:request con 'Tremove (9p:handle-fid h)) (9p:release-handle h))))
354
355(define (9p:read-directory h show-dotfiles?)
356  (let loop ((result (list))
357             (pos 0))
358    (let* ((response (9p:request (9p:handle-connection h) 'Tread (9p:handle-fid h) pos (9p:handle-iounit h)))
359           (data (car (9p:message-contents response)))
360           (read (u8vector-length data)))
361      (if (zero? read)
362          (9p:data->directory-listing (apply u8vector-append! (reverse result)) show-dotfiles?)
363          (loop (cons data result) (+ pos read))))))
364
365(define (9p:open-output-file con file . rest)
366  (let ((h (if (9p:file-exists? con file)
367               (9p:file-open con file 9p:open/wronly)
368               (let-optionals rest ((mode (bitwise-ior 9p:perm/irusr 9p:perm/iwusr
369                                                       9p:perm/irgrp 9p:perm/iwgrp
370                                                       9p:perm/iroth 9p:perm/iwoth)))
371                              (9p:file-create con file 9p:open/wronly mode)))))
372    (make-output-port (lambda (s) (9p:file-write h s)) (lambda () (9p:file-close h)))))
373
374(define (9p:call-with-output-file con file procedure)
375  (let ((p (9p:open-output-file con file)))
376    (handle-exceptions exn (begin (close-output-port p) (signal exn))
377      (let ((result (procedure p)))
378        (close-output-port p)
379        result))))
380
381(define (9p:with-output-to-file con file thunk)
382  (9p:call-with-output-file con file (lambda (p) (parameterize ((current-output-port p)) (thunk)))))
383
384(define (9p:open-input-file con file)
385  (let* ((h (9p:file-open con file 9p:open/rdonly))
386         (buffer #f)
387         (buffer-offset 0)
388         (buffer-size 0))
389    (make-input-port (lambda ()
390                       ; This procedure does some string/blob/u8vector gymnastics so it returns raw
391                       ; byte characters both when utf8 is loaded and when it's not.
392                       ; The highlevel "read" procedures are overridden by utf8, but low-level
393                       ; procedures are still expected to return byte-chars.  That's why we can't
394                       ; use string-ref here (because it may really be utf8's string-ref).
395                       (if buffer
396                           (let ((char (integer->char (u8vector-ref buffer buffer-offset))))
397                            (set! buffer-offset (add1 buffer-offset))
398                            (when (= buffer-offset buffer-size)
399                                  (set! buffer-offset 0)
400                                  (set! buffer #f))
401                            char)
402                           (let ((result (9p:file-read h (min 1024 (9p:handle-iounit h)))))
403                             (cond
404                              ((zero? (second result)) #!eof)
405                              ((= (second result) 1) (integer->char (u8vector-ref (blob->u8vector/shared (string->blob (car result))) 0)))
406                              (else (set! buffer (blob->u8vector/shared (string->blob (car result))))
407                                    (set! buffer-size (second result))
408                                    (set! buffer-offet 1)
409                                    (integer->char (u8vector-ref buffer 0)))))))
410                     (constantly #t)
411                     (lambda ()
412                       (9p:file-close h)))))
413
414(define (9p:call-with-input-file con file procedure)
415  (let* ((p (9p:open-input-file con file))
416         (result (procedure p)))
417    (close-input-port p)
418    result))
419
420(define (9p:with-input-from-file con file thunk)
421  (9p:call-with-input-file con file (lambda (p) (parameterize ((current-input-port p)) (thunk)))))
Note: See TracBrowser for help on using the repository browser.