9p.scm

Nealey's public domain 9P client implementation using gauche's networking.

bash-4.3# 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-4.3#