;;;; 9p-lolevel.scm
;
;; An implementation of the Plan 9 File Protocol (9p)
;; This egg implements the version known as 9p2000 or Styx.
;;
;; This file contains the dirty low-level stuff like network byte
;; packing and the actual transmission and receival of messages.
;
; Copyright (c) 2007, Peter Bex
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Please report bugs, suggestions and ideas to the Chicken Trac
; ticket tracking system (assign tickets to user 'sjamaan'):
; http://trac.callcc.org

;;
;; Notes:
;; Perhaps a dyn-vector can be used instead of lists of u8vectors.
;; Possibly this is more efficient.

(declare
 (export 9p:qid? make-9p:qid 9p:qid-type 9p:qid-version 9p:qid-path
	 9p:qid-type-set! 9p:qid-version-set! 9p:qid-path-set!
	 9p:open/rdonly 9p:open/wronly 9p:open/rdwr 9p:open/trunc 9p:open/rclose
	 9p:perm/ixoth 9p:perm/iwoth 9p:perm/iroth
	 9p:perm/ixusr 9p:perm/iwusr 9p:perm/irusr
	 9p:perm/ixgrp 9p:perm/iwgrp 9p:perm/irgrp
	 9p:dmdir 9p:dmappend 9p:dmexcl 9p:dmauth 9p:dmtmp
	 9p:qtfile 9p:qtdir 9p:qtappend 9p:qtexcl 9p:qtauth 9p:qttmp
	 9p:notag 9p:nofid 9p:stat-keep-number 9p:stat-keep-string
	 9p:message? make-9p:message 9p:message-type 9p:message-tag 9p:message-contents
	 9p:send-message 9p:receive-message 9p:data->directory-listing
	 9p:message-type-set! 9p:message-contents-set! 9p:message-tag-set!))

(use srfi-1 srfi-4 srfi-8 srfi-18 posix)

(define-record 9p:qid
  type version path)

;; Open flags
(define 9p:open/rdonly #x00)
(define 9p:open/wronly #x01)
(define 9p:open/rdwr #x02)
(define 9p:open/trunc #x10)
(define 9p:open/rclose #x40) ;; Remove/unlink on clunk/close

;; Note that for Unix systems these permissions are the same (?).
;; For Windows system these may not be the same.  In any case, we don't
;; want to make assumptions about these things.
(define 9p:perm/ixoth #o001)
(define 9p:perm/iwoth #o002)
(define 9p:perm/iroth #o004)
(define 9p:perm/ixgrp #o010)
(define 9p:perm/iwgrp #o020)
(define 9p:perm/irgrp #o040)
(define 9p:perm/ixusr #o100)
(define 9p:perm/iwusr #o200)
(define 9p:perm/irusr #o400)

(define 9p:dmdir    #x80000000) ; Is a directory
(define 9p:dmappend #x40000000) ; Append-only
(define 9p:dmexcl   #x20000000) ; Exclusive use
; #x08000000 is skipped "for historical reasons"
(define 9p:dmauth   #x04000000) ; Authentication file (established by auth messages)
(define 9p:dmtmp    #x02000000) ; Temporary file

(define 9p:qtfile   #x00) ; Don't check for this!
(define 9p:qtdir    #x80)
(define 9p:qtappend #x40)
(define 9p:qtexcl   #x20)
; #x08 is skipped "for historical reasons"
(define 9p:qtauth   #x08)
(define 9p:qttmp    #x04)

(define 9p:notag #xffff)      ;; For Tversion
(define 9p:nofid #xffffffff)  ;; For Tattach

;; For Twstat messages, when the server should keep the current value (aka "don't touch" in the manpage)
(define 9p:stat-keep-number #xffffffff)
(define 9p:stat-keep-string "")

(define message-types
  `((Tversion msize string)
    (Rversion msize string)
    (Tauth    fid string string)
    (Rauth    qid)
    (Tattach  fid fid string string)
    (Rattach  qid)
    (Terror   )
    (Rerror   string)
    (Tflush   tag)
    (Rflush   )
    (Twalk    fid fid (string))
    (Rwalk    (qid))
    (Topen    fid access-mode)
    (Ropen    qid msize)
    (Tcreate  fid string permission-mode access-mode)
    (Rcreate  qid msize)
    (Tread    fid filesize datasize)
    (Rread    data)
    (Twrite   fid filesize data)
    (Rwrite   datasize)
    (Tclunk   fid)
    (Rclunk   )
    (Tremove  fid)
    (Rremove  )
    (Tstat    fid)
    ;; XXX Double statsize is a bit weird. See the BUGS section in stat(9) for something that is supposed to pass for an explanation
    (Rstat    statsize statsize type dev qid permission-mode time time filesize string string string string)
    (Twstat   fid statsize statsize type dev qid permission-mode time time filesize string string string string) ;; Untested!
    (Rwstat)))

;; These vectors are in reverse network byte ordering because the 9p protocol
;; expects them that way.  (ie, little endian)
(define (u8vector->number v)
  (let loop ((i (u8vector-length v))
	     (num 0))
    (if (zero? i)
	num
        (loop (sub1 i)
	      (+ (arithmetic-shift num 8)
		 (u8vector-ref v (sub1 i)))))))

(define (number->u8vector size number)
  (let ((v (make-u8vector size 0)))
    (let loop ((i size)
	       (num number))
      (if (zero? i)
	  (if (zero? num)
	      v
	      ;; Internal error
	      (error (sprintf "Number too large: ~A can't be split into an u8vector of ~A entries" number size)))
	  (begin
	    (u8vector-set! v (- size i) (inexact->exact (modulo num 256))) ; XXX
	    (loop (sub1 i) (quotient num 256)))))))

(define (u8vector-slice v start length)
  (subu8vector v start (+ start length)))

;; Raise an 'unknown message' exception
(define (unknown-message-error message-type)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message (sprintf "Unknown 9p message type: ~S" message-type))
    (make-property-condition '9p-protocol 'message-type message-type))))

;; Locate the message in the list along with its numerical code
(define (find-message message-type)
  (let loop ((msgs message-types)
	     (pos  0))
    (cond
     ((null? msgs) (unknown-message-error message-type))
     ((eq? (caar msgs) message-type) (values (car msgs) (+ 100 pos)))
     (else (loop (cdr msgs) (add1 pos))))))

(define (send-packet port packet)
  (map (lambda (v) (write-u8vector v port)) packet)
  (flush-output port))

;; Total size of all u8vectors in this packet (as a u8vector)
(define (packet-size len packet)
  (number->u8vector len (fold (lambda (v total) (+ total (u8vector-length v))) len packet)))

;; Create a 'message format error' condition.
;; This condition signals a protocol violation
(define (message-format-error message-type expected actual . rest)
  (let-optionals rest ((information #f))
    (signal
     (make-composite-condition
      (if information
	  (make-property-condition 'exn 'message (sprintf "~A: Expected an argument of the form ~S, got: ~S" information expected actual))
	  (make-property-condition 'exn 'message (sprintf "Expected an argument of the form ~S, got: ~S" expected actual)))
      (make-property-condition '9p-protocol 'message-type message-type 'expected expected 'actual actual)))))

;; Pack an argument for network transfer and check it against the template type.
;; Return value is a list of u8vectors that encode this argument.
(define (pack-argument message-type type arg)
  (if (and (list? type) (null? (cdr type)))  ; If cdr isn't null, it's malformed
      (begin
	(if (list? arg)
	    (let ((result (apply append (map (lambda (entry) (pack-argument message-type (car type) entry)) arg))))
	      (cons (number->u8vector 2 (/ (length result) 2)) result))
	    (message-format-error message-type type arg)))
      (case type
	((msize fid time permission-mode datasize access-mode)
	 (list (number->u8vector 4 arg)))
	((qid)
	 (list (number->u8vector 1 (9p:qid-type arg))
	       (number->u8vector 4 (9p:qid-version arg))
	       (number->u8vector 8 (9p:qid-path arg))))
	((filesize) (list (number->u8vector  8 arg)))
	((data)
	 (list (number->u8vector 4 (u8vector-length arg)) arg))
	((string)
	 (list (number->u8vector 2 (string-length arg)) (blob->u8vector/shared (string->blob arg))))
	;; Internal error
	(else (error (sprintf "Unknown type: ~S, arg = ~S" type arg))))))

(define (construct-packet code message-type tag orig-contents)
  (let loop ((template (cdr message-type))
	     (contents orig-contents)
	     (data (list (u8vector code) (number->u8vector 2 tag))))
    (cond
     ((null? template)
      (if (null? contents)
	  (cons (packet-size 4 data) data)
	  (message-format-error (car message-type) (cdr message-type) orig-contents "Too many arguments for message")))
     ((null? contents)
      (message-format-error (car message-type) (cdr message-type) orig-contents "Too few arguments for message"))
     ((eq? (car template) 'statsize)  ;; Ugly exception.  Continue the loop with a new list and cons length onto it
      (let* ((rest (loop (cdr template) contents '()))
	     (newpacket `(,@data ,(u8vector-slice (car rest) 0 2) ,@(cdr rest))))
	(cons (packet-size 4 newpacket) newpacket)))
     ((eq? (car template) 'dev)  ;; "kernel use"
      (loop (cdr template) contents (append data (list (number->u8vector 4 0)))))
     ((eq? (car template) 'type)  ;; "kernel use"
      (loop (cdr template) contents (append data (list (number->u8vector 2 0)))))
     (else
      (loop (cdr template)
	    (cdr contents)
	    (append data (pack-argument message-type (car template) (car contents))))))))

(define (9p:send-message outport message)
  (receive (template code)
      (find-message (9p:message-type message))
    (send-packet outport
		 (construct-packet code
				   template
				   (if (eq? (9p:message-type message) 'Tversion)
				       9p:notag
				       (9p:message-tag message))
				   (9p:message-contents message)))))

(define-record 9p:message
  type tag contents)

(define (read-packet port)
  (let ((size (u8vector->number (read-u8vector 4 port))))
    (read-u8vector (- size 4) port)))

;; Unpack an argument from the network and make something useful out of it (a list of stuff and the length of the stuff parsed)
(define (unpack-argument type packet offset)
  (if (and (list? type) (null? (cdr type))) ; If cdr isn't null, it's malformed
      (let ((todo (u8vector->number (u8vector-slice packet offset 2))))
	(let build-result ((step 0)
			   (len 0)
			   (offset (+ offset 2))
			   (result '()))
	  (if (= step todo)
	      (values (+ 2 len) result) ; + 2 for the 2-byte length of the list
	      (receive (piece-length piece)
		   (unpack-argument (car type) packet offset)
		 (build-result (add1 step) (+ len piece-length) (+ offset piece-length) (append result piece))))))
      (case type
	((msize fid permission-mode access-mode datasize time)
	 (values 4 (list (u8vector->number (u8vector-slice packet offset 4)))))
	((qid)
	 (let ((mode (u8vector->number (u8vector-slice packet offset 1)))
		(version (u8vector->number (u8vector-slice packet (+ offset 1) 4)))
		(path (u8vector->number (u8vector-slice packet (+ offset 5) 8))))
	  (values 13 (list (make-9p:qid mode version path)))))
	((filesize)
	 (values 8 (list (u8vector->number (u8vector-slice packet offset 8)))))
	((data)
	 (let ((datasize (u8vector->number (u8vector-slice packet offset 4))))
	   (values (+ datasize 4) (list (u8vector-slice packet (+ offset 4) datasize)))))
	((statsize type)
	 (values 2 (list))) ; type is "for kernel use", statsize is redundant and pointless, discard
	((dev)
	 (values 4 (list))) ; dev is "for kernel use", discard
	((string)
	 (let* ((len (u8vector->number (u8vector-slice packet offset 2)))
		(str (blob->string (u8vector->blob/shared (u8vector-slice packet (+ offset 2) len)))))
	   (values (+ 2 len) (list str))))
	;; Internal error
	(else (error (sprintf "Unknown type: ~A, packet = ~S, offset = ~A" type packet offset))))))

;; Extract (tag message-type . message-contents) from a packet u8vector
(define (deconstruct-packet packet)
  (let* ((code (u8vector->number (subu8vector packet 0 1)))
	 (message-type (list-ref message-types (- code 100)))
	 (tag (u8vector->number (subu8vector packet 1 3)))
	 (packet-length (u8vector-length packet)))
    (let loop ((offset 3)
	       (template (cdr message-type))
	       (data '()))
      (cond
       ((null? template)
	(if (= offset (u8vector-length packet))
	    (make-9p:message (car message-type) tag data)
	    (message-format-error (car message-type) (cdr message-type) packet "Too large packet for message")))
       ((= offset packet-length)
	(message-format-error (car message-type) (cdr message-type) packet "Too small packet for message"))
       (else
	(receive (fragment-size contents) (unpack-argument (car template) packet offset)
	 (loop (+ offset fragment-size)
	       (cdr template)
	       (append data contents))))))))

(define (9p:receive-message inport)
  (let* ((packet (read-packet inport)))
    (deconstruct-packet packet)))

;; Ugly hack needed because READ is overloaded to return structured data if we're reading a dir
(define (9p:data->directory-listing data show-dotfiles?)
  (receive (message-structure num)
	   (find-message 'Rstat)
    (let next-entry ((entries (list))
		     (offset 0))
      (if (= offset (u8vector-length data))
	  entries
	  (let next-piece ((remaining-structure (cddr message-structure))
			   (pieces (list))
			   (offset offset))
	    (if (null? remaining-structure)
		(let ((entry (car (list-ref pieces 3)))) ; Filename (we don't bother to reverse the list)
		  (if (and (not show-dotfiles?) (char=? (string-ref entry 0) #\.))
		      (next-entry entries offset)
		      (next-entry (cons entry entries) offset)))
		(receive (fragment-size contents) (unpack-argument (car remaining-structure) data offset)
			 (next-piece (cdr remaining-structure)
				     (cons contents pieces)
				     (+ offset fragment-size)))))))))