9p.scm
bash-5.1$ cat 9p.scm
#! /usr/bin/gosh
;; Description: 9p implementation in Scheme
;; Author: Neale Pickett
;; This uses gauche's networking stuff, but no other gauche stuff. It
;; should be possible to substitute your implementation's networking
;; procedures without too much effort.
(use gauche.net)
(require-extension (srfi 1 4 8 9))
(define message-specs
;; name num format
'((TVersion 100 (2 4 s)) ;x64
(RVersion 101 (2 4 s))
(TAuth 102 (2 4 s s))
(RAuth 103 (2 13))
(TAttach 104 (2 4 4 s s)) ;x68
(RAttach 105 (2 13))
(TError 106 ()) ;illegal
(RError 107 (2 s))
(TFlush 108 (2 2)) ;x6c
(RFlush 109 (2))
(TWalk 110 (2 4 4 (2 . s)))
(RWalk 111 (2 (2 . 13)))
(TOpen 112 (2 4 1)) ;x70
(ROpen 113 (2 13 4))
(TCreate 114 (2 4 s 4 1))
(RCreate 115 (2 13 4))
(TRead 116 (2 4 8 4)) ;x74
(RRead 117 (2 (4 . d)))
(TWrite 118 (2 4 8 (4 . s)))
(RRwrite 119 (2 4))
(TClunk 120 (2 4)) ;x78
(RClunk 121 (2))
(TRemove 122 (2 4))
(RRemove 123 (2))
(TStat 124 (2 4)) ;x7c
(RStat 125 (2 n))
(TWStat 126 (2 4 n))
(RWStat 127 (2)))) ;x7f
(define (spec-by-num num)
(let loop ((specs message-specs))
(cond
((null? specs)
#f)
((equal? (cadar specs) num)
(car specs))
(else
(loop (cdr specs))))))
;;
;; Helper procedures
;;
(define (u8-list->uint l)
(let loop ((l (reverse l))
(acc 0))
(if (null? l)
acc
(loop (cdr l)
(+ (* 256 acc)
(car l))))))
(define (uint->u8-list width i)
(if (zero? width)
'()
(let ((b (modulo i 256))
(r (floor (/ i 256))))
(cons b (uint->u8-list (- width 1) r)))))
;; XXX: s had better be printable 7-bit ASCII
(define (string->u8-list s)
(map char->integer (string->list s)))
(define (u8-list->string l)
(list->string (map integer->char l)))
;;
;; Packing and unpacking, both deal with u8-lists
;;
(define (pack fmt args)
(let loop ((fmt fmt)
(args args)
(acc '()))
;;(write (list fmt args acc)) (newline)
(cond
((null? fmt)
acc)
((number? (car fmt))
(loop (cdr fmt)
(cdr args)
(append acc (uint->u8-list (car fmt) (car args)))))
((equal? (car fmt) 's)
;;XXX Should handle UTF-8
(loop (cdr fmt)
(cdr args)
(append acc
(uint->u8-list 2 (string-length (car args)))
(string->u8-list (car args)))))
((pair? (car fmt))
;; fmt item is (c . type), which gets packed to a c-octet n,
;; followed by n types.
(let ((count (length (car args))))
(loop (cdr fmt)
(cdr args)
(append acc
(uint->u8-list (caar fmt) count)
(pack (make-list count (cdar fmt))
(car args))))))
((equal? (car fmt) 'n)
;; XXX: total guess here
(loop (cdr fmt)
(cdr args)
(append acc (car args))))
(else
(error (format "Unknown format element: ~a" (car fmt)))))))
(define (unpack fmt l)
(reverse
(let loop ((fmt fmt)
(l l)
(acc '()))
;;(write (list fmt l acc)) (newline)
(cond
((null? fmt)
acc)
((number? (car fmt))
(loop (cdr fmt)
(drop l (car fmt))
(cons (u8-list->uint (take l (car fmt)))
acc)))
((equal? (car fmt) 's)
(let ((len (u8-list->uint (take l 2)))
(m (drop l 2)))
(loop (cdr fmt)
(drop m len)
(cons (u8-list->string (take m len))
acc))))
((pair? (car fmt))
(let* ((count (u8-list->uint (take l (caar fmt))))
(m (drop l (caar fmt))))
(receive (p octets)
(case (cdar fmt)
((s)
(let ((p (reverse (unpack (make-list count (cdar fmt))
l))))
(values p
(reduce + 0 (map string-length p)))))
((d)
(values (take m count)
count))
(else
(values (reverse (unpack (make-list count (cdar fmt))
l))
(* count (cdar fmt)))))
(loop (cdr fmt)
(drop m octets)
(cons p acc)))))
(else
(error (format "Unknown format element: ~a" (car fmt))))))))
;;
;; Packet assembly and disassembly
;;
(define (make-packet type . args)
(let* ((spec (cdr (assoc type message-specs)))
(msgnum (car spec))
(fmt (cadr spec))
(p (pack fmt args)))
(append (uint->u8-list 4 (+ 5 (length p)))
(list msgnum)
p)))
(define (write-packet ixp type . args)
((ixp-write ixp) (apply make-packet (cons type args))))
(define (read-uint width ixp)
(u8-list->uint ((ixp-read ixp) width)))
(define (read-packet ixp)
(let* ((len (read-uint 4 ixp))
(msgnum (read-uint 1 ixp))
(spec (spec-by-num msgnum))
(fmt (caddr spec))
(datum ((ixp-read ixp) (- len 5))))
(cons (car spec)
(unpack fmt datum))))
;;
;; 9p record
;;
;; This is how I deal with the fact that no two scheme implementations
;; have the same socket API. There are no SRFIs for sockets so that's
;; not likely to change in the near future.
;;
;; You create one of these with (make-ixp read-u8-list write-u8-list).
;; read-u8-list should one argument, count, and return a list of length
;; count of octets (u8s) read from the socket. write-u8-list takes one
;; argument, l (a u8-list), and writes that to the socket.
;;
(define-record-type ixp
(make-ixp read-u8-list write-u8-list)
ixp?
(read-u8-list ixp-read)
(write-u8-list ixp-write))
(define (ixp-transaction ixp type . args)
(apply write-packet (append (list ixp type 1) args))
(let ((ret (read-packet ixp)))
(if (equal? (car ret) 'RError)
(error (format "IXP Recieve: ~a" ret))
ret)))
;; Rewriting this procedure should be all you need to do in order to
;; port this code.
(define (gauche-with-ixp socket proc)
(call-with-client-socket socket
(lambda (in out)
(let ((ixp (make-ixp
(lambda (count)
(let ((vec (make-u8vector count)))
(if (not (equal? (read-block! vec in) count))
(error "read-octets: short read")
(u8vector->list vec))))
(lambda (u8-list)
(write-block (list->u8vector u8-list) out)
(flush out)))))
(proc ixp)))))
(define (main args)
(gauche-with-ixp (make-client-socket 'unix "/tmp/ns.neale.:0/wmii")
(lambda (ixp)
(let ((root-fid #xf00fb1ba)
(fid 1)
(username "the dink")
(filename "event")
(data "hello\n"))
(ixp-transaction ixp 'TVersion 4096 "9P2000")
(ixp-transaction ixp 'TAttach root-fid #xffffffff username "")
(ixp-transaction ixp 'TWalk root-fid fid (list filename))
(ixp-transaction ixp 'TOpen fid 1)
(ixp-transaction ixp 'TWrite fid 0 (list data))
(ixp-transaction ixp 'TClunk fid)
(ixp-transaction ixp 'TWalk root-fid fid (list filename))
(ixp-transaction ixp 'TOpen fid 0)
(write
(let ((cl (caddr (ixp-transaction ixp 'TRead fid 0 4096))))
(ixp-transaction ixp 'TClunk fid)
(u8-list->string cl)))
(newline))))
0)
bash-5.1$
simpleExamples.tcl
bash-5.1$ cat simpleExamples.tcl
#!/bin/sh
#-*-tcl-*-
# the next line restarts using wish \
exec tclsh "$0" ${1+"$@"}
catch {console show}
puts "(pwd is '[pwd]', file volumes is '[file volumes]')"
package require vfs
package require vfs::zip
package require vfs::urltype
package require vfs::ftp
package require vfs::http
puts "Adding ftp:// volume..."
vfs::urltype::Mount ftp
set listing [glob -dir ftp://ftp.belnet.be *]
puts "ftp.belnet.be listing"
puts "$listing"
puts "----"
puts "(file volumes is '[file volumes]')"
puts "Adding http:// volume..."
vfs::urltype::Mount http
set fd [open http://sourceforge.net/projects/tcl]
set contents [read $fd] ; close $fd
puts "Contents of <http: projects="" sourceforge.net="" tcl=""> web page"
puts [string range $contents 0 100]
puts "(first 100 out of [string length $contents] characters)"
puts "----"
puts "(file volumes is '[file volumes]')"
puts "Mounting ftp://ftp.ucsd.edu/pub/alpha/ ..."
vfs::ftp::Mount ftp://ftp.ucsd.edu/pub/alpha/ localmount
cd localmount ; cd tcl
puts "(pwd is now '[pwd]' which is effectively a transparent link\
to a remote ftp site)"
puts "Contents of remote directory is:"
foreach file [glob -nocomplain *] {
puts "\t$file"
}
puts "sourcing remote file 'vfsTktest.tcl', using 'source vfsTktest.tcl'"
# This will actually source the contents of a file on the
# remote ftp site (which is now the 'pwd').
source vfsTktest.tcl
puts "Done"
bash-5.1$
varietes_cidricoles
Antoinette:(2.73 / 36.79):1050:douce amere:
Argile Rouge Bruyère:::douce amere:
Armagnac:(1.7 / 121.21):1065:aigre:
Avrolles:(0.87 / 178.99):1055:aigre:
Bedan:(2.27 / 22.04):1056:douce amere:
Belle Fille de la Manche:::douce:
Binet Blanc:(2.52 / 26.5):1060:douce amere:
Binet Rouge:(2.41 / 26.54):1063:douce amere:
Binet Violet:(2.62 / 24.93):1050:douce amere:
Bisquet:(2.12 / 31.31):1045:douce amere:
Blanc Sur:(1.23 / 99.25):1055:aigre:
Blanchet:(1.28 / 71.4):1050:acidulee:
C'Huero Briz:(4.67 / 30.65):1056:amere:
C'Huero Ru:::douce amere:
Cartigny:(2.21 / 31.26):1051:douce amere:
Cazo Jaune:(3.28 / 196.2):1054:aigre amere:
Chevalier Jaune:(3.79 / 33.09):1053:amere:
Cidor:(4.02 / 25.9):1055:amere:®
Clos Renaux:(2.2 / 36.91):1052:douce amere:
Clozette Douce:(2.32 / 33.25):1054:douce amere:
Diot Roux:(1.85 / 146.48):1052:aigre:
Domaines:(3.6 / 31.81):1067:amere:
Douce Coetligné:(1.83 / 29.09):1051:douce:
Douce Moen:(2.43 / 31.85):1061:douce amere:
Doux Evêque Jaune:(1.96 / 24.25):1052:douce:
Doux Joseph:(3.61 / 31.04):1058:amere:
Doux Lozon:(2.13 / 21.21):1053:douce amere:
Doux Normandie:(1.42 / 24.56):1065:douce:
Doux Veret de Carrouges:(1.77 / 24.62):1055:douce:
Doux au Gober:::douce:
Fréquin Rouge Petit:(5.06 / 36.35):1065:amere:
Gesnot:(1.11 / 97):1049:aigre:
Gros Bois:(2.86 / 42.15):1050:douce amere:
Gros Oeillet:::douce amere:
Guillevic:(1.35 / 86.29):1059:acidulee:
Jaune de Vitré:(1.61 / 132.44):1060:aigre:
Jeanne Renard:(4.23 / 25.35):1065:amere:
Judaine:(0.75 / 100.4):1053:aigre:®
Judeline:(0.67 / 75.42):1050:acidulee:®
Judin:(0.89 / 98.24):1060:aigre:
Judor:(0.73 / 100.63):1052:aigre:
Juliana:(1.78 / 154):1061:aigre:®
Jurella:(0.61 / 126.7):1053:aigre:
Kermerrien:(4.32 / 22.17):1062:amere:
Locard Blanc:::acidulee:
Locard Vert:::aigre:
Marie Ménard:(4.82 / 32.78):1061:amere:
Marin Onfroy:(3.25 / 25.5):1059:amere:
Meriennet:::amere:
Mettais:(3.78 / 25.61):1063:amere:
Moulin à Vent:(2.7 / 38.96):1061:douce amere:
Muscadet Petit de l'Orne:(1.9 / 24.23):1061:douce:
Muscadet de Dieppe:(2.54 / 30.95):1055:douce amere:
Noël des Champs:(2.33 / 22.6):1050:douce amere:
Omont:(2.2 / 29):1063:douce amere:
Peau de Chien:(2.95 / 32.25):1065:douce amere:
Petit Amer:(4.43 / 29.65):1055:amere:
Petit Jaune:(1.2 / 110.59):1055:aigre:
Pomme de Bouet:::aigre:
Pomme de Moi:::acidulee:
Queue Torte:::douce:
Rambault:(1.4 / 95.76):1061:aigre:
Rénao:::aigre:
René Martin:(1.38 / 113.31):1053:aigre:
Rouge Duret:(1.65 / 25.3):1049:douce:
Rouget de Dol Gros:::acidulee:
Rousse de la Sarthe:(1.64 / 25.22):1056:douce:
Saint Martin:(2.27 / 30.09):1055:douce amere:
Sebin Blanc:(1.44 / 81.2):1051:acidulee:
Tardive de la Sarthe:(3.68 / 29.51):1059:amere:
Tesnière:(1.56 / 83.97):1055:acidulee:
