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

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

Re-add the 'let' statement in call-with-output-file (d'oh!)

File size: 16.7 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(use 9p-lolevel srfi-13 iset)
37
38(define-record 9p:connection
39  inport outport message-size open-fids)
40
41(define (9p:server-error message-type error-message)
42  (signal
43   (make-composite-condition
44    (make-property-condition 'exn 'message (sprintf "9p server returned ~S for message ~A" error-message message-type))
45    (make-property-condition '9p-server-error 'message-type message-type))))
46
47(define (9p:response-error message-type response-type)
48  (signal
49   (make-composite-condition
50    (make-property-condition 'exn 'message (sprintf "9p server returned unexpected response type ~S for message ~A" response-type message-type))
51    (make-property-condition '9p-response-error 'message-type message-type))))
52
53;; Client request.  Sends a message of the given type and args and waits
54;; for a matching response (a Rxyz response matches a Txyz request).
55(define (9p:request con type . args)
56  ;; Always use a tag of 1
57  (9p:send-message (9p:connection-outport con) (make-9p:message type 1 args))
58  (let ((response (9p:receive-message (9p:connection-inport con)))
59        (expected-type (string->symbol (string-replace (symbol->string type) "R" 0 1))))
60    (cond
61     ((eq? (9p:message-type response) expected-type)
62      response)
63     ((eq? (9p:message-type response) 'Rerror)
64      (9p:server-error type (car (9p:message-contents response))))
65     (else
66      (9p:response-error type (9p:message-type response))))))
67
68;; Initialize a connection to a 9p server ("mount"/"bind")
69;; Authentication is currently not supported
70(define (9p:client-connect inport outport . rest)
71  (let-optionals rest ((user "")
72                       (mountpoint ""))
73    (let* ((bv (make-bit-vector 8))  ; Start out with 8 bits.  Let it grow only when needed
74           (con (make-9p:connection inport outport #xffffffff bv))
75            ; We can handle message size #xffffffff but wmii/libixp crashes on that. #x7ffffff is the absolute max for it
76           (answer (9p:request con 'Tversion #x7fffffff "9P2000")))
77      (cond
78       ((not (string=? "9P2000" (cadr (9p:message-contents answer))))
79        (error (sprintf "Incompatible protocol version: ~S" (9p:message-contents answer))))
80       (else
81        (9p:connection-message-size-set! con (car (9p:message-contents answer)))
82        ;; To authenticate, do a Tauth request, authenticate and use the fid we got
83        ;; when authenticating instead of nofid below.
84        ;;
85        ;; Allocate the root fid using alloc-handle so we automatically get a finalizer set
86        (9p:request con 'Tattach (9p:handle-fid (9p:alloc-handle con)) nofid user mountpoint)
87        con)))))
88
89;; Sever connection, clunk all fids
90(define (9p:client-disconnect con)
91  (let ((fids (9p:connection-open-fids con)))
92    (let loop ((fid (bit-vector-length fids)))
93      (when (not (zero? fid))
94        (when (bit-vector-ref fids (sub1 fid))
95          (9p:file-close (make-9p:handle con (sub1 fid) 0 #f)))
96        (loop (sub1 fid))))))
97
98;; File IDs and handles
99(define-record 9p:handle
100  connection fid position iounit)
101
102(define (9p:initialize-iounit! h iounit)
103  (9p:handle-iounit-set!
104   h
105   (if (zero? iounit)
106       ;; 23 is the biggest size of a message (write), but libixp uses 24, so we do too to stay safe
107       (- (9p:connection-message-size (9p:handle-connection h)) 24)
108       iounit)))
109
110;; Allocate the lowest fid that's not in use yet and return a handle to it
111(define (9p:alloc-handle con)
112  (let loop ((fids (9p:connection-open-fids con))
113             (highest 0))
114    (cond
115     ((bit-vector-full? fids (add1 highest))
116      (loop fids (add1 highest)))
117     ((>= highest nofid)
118      (error "Out of file ids"))
119     (else
120      (9p:connection-open-fids-set! con (bit-vector-set! fids highest #t))
121      (make-9p:handle con highest 0 #f)))))
122
123;; Deallocate the given handle from the list (does _not_ clunk it)
124(define (9p:release-handle h)
125  (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))
126  ;; Invalidate the handle
127  (9p:handle-connection-set! h #f)
128  (9p:handle-fid-set! h #f)
129  (9p:handle-iounit-set! h #f)
130  (void))
131
132;; Make a list of path components.  Accepts either a string which it will split
133;; at slashes, or a pre-made path component list.
134(define (9p:normalize-path path)
135  (if (pair? path)
136      path
137      (string-split path "/")))
138
139;; Obtain a new fid
140(define (9p:path-walk con path . rest)
141  (let-optionals rest ((starting-point 0))
142    (let ((new-handle (9p:alloc-handle con)))
143      (handle-exceptions exn (begin (9p:release-handle new-handle) (signal exn))
144       (9p:message-contents (9p:request con 'Twalk starting-point (9p:handle-fid new-handle) (9p:normalize-path path)))
145       new-handle))))
146
147;; Clunk a fid
148(define (9p:file-close h)
149  (when (9p:handle-connection h) ; Ignore invalid handles (if already closed, closing again is ok)
150   (9p:request (9p:handle-connection h) 'Tclunk (9p:handle-fid h))
151   (9p:release-handle h)))
152
153;; With a temporary handle to a file, perform some other procedure
154;; The handle gets walked to and clunked automatically
155(define (9p:with-handle-to con path procedure)
156  (let ((h (9p:path-walk con path)))
157    (handle-exceptions
158     exn
159     (begin
160       (9p:file-close h)
161       (signal exn)) ;; Just reraise it
162     (let ((result (call-with-values (lambda () (procedure h)) list)))
163       (9p:file-close h)
164       (apply values result)))))
165
166;; This is a hack, as the server might return other errors beside "file does not exist",
167;; but there's no way we can really ask this question otherwise.
168(define (9p:file-exists? con path)
169  (condition-case (9p:with-handle-to con path (constantly #t))
170    ((exn 9p-server-error) #f)))
171
172(define (9p:file-open con name mode)
173  (let* ((h (9p:path-walk con name))
174         (response (9p:request (9p:handle-connection h) 'Topen (9p:handle-fid h) mode))
175         (iounit (second (9p:message-contents response))))
176    (9p:initialize-iounit! h iounit)
177    h))
178
179;; This duplicates much of with-handle-to, but 9p isn't very consistent here: the
180;; fid that initially represents the directory is now reused and represents the
181;; newly created file, so we can't use with-handle-to (or we'd have to reopen the
182;; file after creating, which is not possible in case of tempfiles)
183(define (9p:file-create con name perm mode)
184  (let ((h (9p:path-walk con (pathname-directory name))))
185    (handle-exceptions
186     exn
187     (begin
188       (9p:file-close h)
189       (signal exn)) ;; Just reraise it
190     (let* ((response (9p:request con 'Tcreate (9p:handle-fid h) (pathname-strip-directory name) perm mode))
191            (iounit (second (9p:message-contents response))))
192       (9p:initialize-iounit! h iounit)
193       h))))
194
195(define (u8vector-append! . vectors)
196  (let* ((length (apply + (map u8vector-length vectors)))
197         (result (make-u8vector length)))
198    (let next-vector ((vectors vectors)
199                      (result-pos 0))
200      (if (null? vectors)
201          result
202          (let next-pos ((vector-pos 0)
203                         (result-pos result-pos))
204            (if (= vector-pos (u8vector-length (car vectors)))
205                (next-vector (cdr vectors) result-pos)
206                (begin
207                  (u8vector-set! result result-pos (u8vector-ref (car vectors) vector-pos))
208                  (next-pos (add1 vector-pos) (add1 result-pos)))))))))
209
210;; TODO: Find a way to use an optional buffer to write in, so we don't end up
211;; copying a whole lot of data around (overhead!)  -- file-write also has this
212;; This is doubly bad because if we have a small message size the copying and
213;; appending really becomes a whole lot of overhead.
214(define (9p:file-read h size)
215  (let loop ((bytes-left size)
216             (total 0)
217             (result (list)))
218    (if (zero? bytes-left)
219        (list (blob->string (u8vector->blob/shared (apply u8vector-append! (reverse result)))) total) ; file-read also returns a list of data + length
220        (let* ((pos (9p:handle-position h))
221               (receive-size (min bytes-left (9p:handle-iounit h)))
222               (response (9p:request (9p:handle-connection h) 'Tread (9p:handle-fid h) pos receive-size))
223               (data (car (9p:message-contents response)))
224               (read (u8vector-length data)))
225          (cond
226           ((zero? read)
227            (loop 0 total (cons (make-u8vector bytes-left (char->integer #\space)) result))) ; Pad with empty u8vector, just like file-read
228           ((> read bytes-left) ; Sometimes the server returns more than we asked for! (when accidentally reading a dir, for example)
229            (9p:handle-position-set! h (+ pos bytes-left))
230            (loop 0 (+ total bytes-left) (cons (u8vector-slice data 0 bytes-left) result)))
231           (else
232            (9p:handle-position-set! h (+ pos read))
233            (loop (- bytes-left read) (+ total read) (cons data result))))))))
234
235(define (9p:file-write h buffer . rest)
236  (let ((buffer (if (string? buffer)
237                    (blob->u8vector/shared (string->blob buffer))
238                    buffer)))
239    (let-optionals rest ((size (u8vector-length buffer)))
240      (let loop ((bytes-left size)
241                 (total 0))
242        (if (zero? bytes-left)
243            total
244            (let* ((pos (9p:handle-position h))
245                   (send-size (min bytes-left (9p:handle-iounit h)))
246                   (response (9p:request (9p:handle-connection h) 'Twrite (9p:handle-fid h) pos (u8vector-slice buffer total send-size)))
247                   (written (car (9p:message-contents response))))
248              (9p:handle-position-set! h (+ pos written))
249              (if (not (= written send-size))
250                  (9p:server-error 'Twrite (sprintf "Unexpected bytecount ~A instead of ~A in Rwrite response (not a proper server error message)" written send-size)))
251              (loop (- bytes-left written) (+ total written))))))))
252
253; (qid permission-mode time time filesize string string string string)
254(define (9p:handle-stat h)
255  (apply values (9p:message-contents (9p:request (9p:handle-connection h) 'Tstat (9p:handle-fid h)))))
256
257(define (9p:file-stat con file)
258  (9p:with-handle-to
259   con file 9p:handle-stat))
260
261(define (9p:file-permissions con file)
262  (call-with-values
263      (lambda () (9p:file-stat con file))
264    (lambda l (list-ref l 1))))
265
266(define (9p:file-access-time con file)
267  (call-with-values
268      (lambda () (9p:file-stat con file))
269    (lambda l (list-ref l 2))))
270
271(define (9p:file-modification-time con file)
272  (call-with-values
273      (lambda () (9p:file-stat con file))
274    (lambda l (list-ref l 3))))
275
276;; There is no file-change-time because the protocol does not provide it.
277
278(define (9p:file-size con file)
279  (call-with-values
280      (lambda () (9p:file-stat con file))
281    (lambda l (list-ref l 4))))
282
283;; 5 is file-name, which is rather silly
284
285;;; Important: The following three procedures return _strings_, not IDs
286(define (9p:file-owner con file)
287  (call-with-values
288      (lambda () (9p:file-stat con file))
289    (lambda l (list-ref l 6))))
290
291(define (9p:file-group con file)
292  (call-with-values
293      (lambda () (9p:file-stat con file))
294    (lambda l (list-ref l 7))))
295
296(define (9p:file-last-modified-by con file)
297  (call-with-values
298      (lambda () (9p:file-stat con file))
299    (lambda l (list-ref l 8))))
300
301(define (9p:directory? con file)
302  (call-with-values
303      (lambda () (9p:file-stat con file))
304    (lambda l (not (zero? (bitwise-and 9p:dmdir (list-ref l 1)))))))
305
306;; TODO: Find out if this is enough.  9p supports no symlinks?
307(define (9p:regular-file? con file)
308  (not (9p:directory? con file)))
309
310(define (9p:set-file-position! h pos . rest)
311  (let-optionals rest ((whence seek/set))
312    (cond
313     ((< 0 pos) (signal (make-composite-condition
314                         (make-property-condition 'exn 'message (sprintf "Invalid negative seek position: ~S" pos))
315                         (make-property-condition 'bounds))))
316     ((eq? whence seek/set)
317      (9p:handle-position-set! h pos))
318     ((eq? whence seek/cur)
319      (9p:handle-position-set! h (+ (9p:handle-position h) pos)))
320     ((eq? whence seek/end)
321      (let ((size (call-with-values
322                      (lambda () (9p:handle-stat h))
323                    (lambda l (list-ref 4)))))
324        ((9p:handle-position-set! h (+ size pos)))))
325     (else (error (sprintf "Unknown seek position type (WHENCE value): ~S" whence))))))
326
327(define 9p:file-position 9p:handle-position)
328
329(define (9p:directory con file . rest)
330  (let-optionals rest ((show-dotfiles? #f))
331   (9p:with-handle-to
332    con file
333    (lambda (h)
334      (call-with-values
335          (lambda () (9p:handle-stat h))
336        (lambda l
337          (if (zero? (bitwise-and 9p:dmdir (list-ref l 1)))
338              (signal (make-composite-condition
339                       (make-property-condition 'exn 'message (sprintf "~S is not a directory!" file))
340                       (make-property-condition 'file)))
341              (let* ((response (9p:request (9p:handle-connection h) 'Topen (9p:handle-fid h) 9p:open/rdonly))
342                     (iounit (second (9p:message-contents response))))
343                (9p:initialize-iounit! h iounit)
344                (9p:read-directory h show-dotfiles?)))))))))
345
346;; NEXT UP: 9P:DELETE-FILE, then 9P:RENAME-FILE
347
348(define (9p:read-directory h show-dotfiles?)
349  (let loop ((result (list))
350             (pos 0))
351    (let* ((response (9p:request (9p:handle-connection h) 'Tread (9p:handle-fid h) pos (9p:handle-iounit h)))
352           (data (car (9p:message-contents response)))
353           (read (u8vector-length data)))
354      (if (zero? read)
355          (9p:data->directory-listing (apply u8vector-append! (reverse result)) show-dotfiles?)
356          (loop (cons data result) (+ pos read))))))
357
358(define (9p:open-output-file con file . rest)
359  (let ((h (if (9p:file-exists? con file)
360               (9p:file-open con file 9p:open/wronly)
361               (let-optionals rest ((mode (bitwise-ior 9p:perm/irusr 9p:perm/iwusr
362                                                       9p:perm/irgrp 9p:perm/iwgrp
363                                                       9p:perm/iroth 9p:perm/iwoth)))
364                              (9p:file-create con file 9p:open/wronly mode)))))
365    (make-output-port (lambda (s) (9p:file-write h s)) (lambda () (9p:file-close h)))))
366
367(define (9p:call-with-output-file con file procedure)
368  (let ((p (9p:open-output-file con file)))
369    (handle-exceptions exn (begin (close-output-port p) (signal exn))
370      (let ((result (procedure p)))
371        (close-output-port p)
372        result))))
373
374(define (9p:with-output-to-file con file thunk)
375  (9p:call-with-output-file con file (lambda (p) (parameterize ((current-output-port p)) (thunk)))))
376
377;; XXX Is a character a real character (utf8 can mean more than 1 byte) or just 1 byte?
378(define (9p:open-input-file con file)
379  (let* ((h (9p:file-open con file 9p:open/rdonly))
380         (buffer #f)
381         (buffer-offset 0)
382         (buffer-size 0))
383    ;; XXX Use a string port for the buffer and read from that
384    (make-input-port (lambda ()
385                       (if buffer
386                           (let ((char (string-ref buffer buffer-offset)))
387                            (set! buffer-offset (add1 buffer-offset))
388                            (when (= buffer-offset buffer-size)
389                                  (set! buffer-offset 0)
390                                  (set! buffer #f))
391                            char)
392                           (let ((result (9p:file-read h (min 1024 (9p:handle-iounit h)))))
393                             (cond
394                              ((zero? (second result)) #!eof)
395                              ((= (second result) 1) (string-ref (car result) 0))
396                              (else (set! buffer (car result))
397                                    (set! buffer-size (second result))
398                                    (set! buffer-offet 1)
399                                    (string-ref buffer 0))))))
400                     (constantly #t)
401                     (lambda ()
402                       (9p:file-close h)))))
403
404(define (9p:call-with-input-file con file procedure)
405  (let* ((p (9p:open-input-file con file))
406         (result (procedure p)))
407    (close-input-port p)
408    result))
409
410(define (9p:with-input-from-file con file thunk)
411  (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.