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$