;;;; 9p.scm
;
;; An implementation of the Plan 9 File Protocol (9p)
;; This egg implements the version known as 9p2000 or Styx.
;;
;; This file contains a posix-like higher-level client-side abstraction over
;; the lower-level connection and message packing/unpacking provided by 9p-lolevel.
;
; 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
;
; TODO: 9p:rename-file.  Unfortunately, 9p has no native 'move' command, so
; this will be hard and very error-prone to do, at least in the case of directories.
; Something for another time :)
;
; TODO: Wstat interface (9p:change-file-owner, 9p:change-file-mode)
; Using this interface we can implement a partially correct rename-file: the
; filename can be changed, but not the rest of the path.
; Beware: the "spec" says changing the owner is illegal, except when the fs was
; configed to allow it?  File length can be changed too...
;
; TODO: Think about how to expose non-POSIX things from 9p properly

(declare
 (export 9p:connection? 9p:request 9p:client-connect 9p:client-disconnect
	 9p:handle? 9p:alloc-handle 9p:release-handle 9p:normalize-path
	 9p:path-walk 9p:file-open 9p:file-close 9p:with-handle-to
	 9p:file-exists? 9p:file-create 9p:file-read 9p:file-write
	 9p:file-stat 9p:file-permissions 9p:file-access-time
	 9p:file-modification-time 9p:file-size 9p:file-owner 9p:file-group
	 9p:file-last-modified-by 9p:directory? 9p:regular-file?
	 9p:set-file-position! 9p:file-position 9p:directory 9p:delete-file
	 9p:open-output-file 9p:call-with-output-file 9p:with-output-to-file
	 9p:open-input-file 9p:call-with-input-file 9p:with-input-from-file)
 (unused 9p:connection-inport-set! 9p:connection-outport-set!))

(use 9p-lolevel srfi-13 iset)

(define-record 9p:connection
  inport outport message-size open-fids)

(define (server-error message-type error-message)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message (sprintf "9p server returned ~S for message ~A" error-message message-type))
    (make-property-condition '9p-server-error 'message-type message-type))))

(define (response-error message-type response-type)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message (sprintf "9p server returned unexpected response type ~S for message ~A" response-type message-type))
    (make-property-condition '9p-response-error 'message-type message-type))))

;; Client request.  Sends a message of the given type and args and waits
;; for a matching response (a Rxyz response matches a Txyz request).
(define (9p:request con type . args)
  ;; Always use a tag of 1
  (9p:send-message (9p:connection-outport con) (make-9p:message type 1 args))
  (let ((response (9p:receive-message (9p:connection-inport con)))
	(expected-type (string->symbol (string-replace (symbol->string type) "R" 0 1))))
    (cond
     ((eq? (9p:message-type response) expected-type)
      response)
     ((eq? (9p:message-type response) 'Rerror)
      (server-error type (car (9p:message-contents response))))
     (else
      (response-error type (9p:message-type response))))))

;; Initialize a connection to a 9p server ("mount"/"bind")
;; Authentication is currently not supported
(define (9p:client-connect inport outport . rest)
  (let-optionals rest ((user "")
		       (mountpoint ""))
    (let* ((bv (make-bit-vector 8))  ; Start out with 8 bits.  Let it grow only when needed
	   (con (make-9p:connection inport outport #xffffffff bv))
	    ; We can handle message size #xffffffff but wmii/libixp crashes on that. #x7ffffff is the absolute max for it
	   (answer (9p:request con 'Tversion #x7fffffff "9P2000")))
      (cond
       ((not (string=? "9P2000" (cadr (9p:message-contents answer))))
	(error (sprintf "Incompatible protocol version: ~S" (9p:message-contents answer))))
       (else
	(9p:connection-message-size-set! con (car (9p:message-contents answer)))
	;; To authenticate, do a Tauth request, authenticate and use the fid we got
	;; when authenticating instead of nofid below.
	;;
	;; Allocate the root fid using alloc-handle so we automatically get a finalizer set
	(9p:request con 'Tattach (9p:handle-fid (9p:alloc-handle con)) 9p:nofid user mountpoint)
	con)))))

;; Sever connection, clunk all fids
(define (9p:client-disconnect con)
  (let ((fids (9p:connection-open-fids con)))
    (let loop ((fid (bit-vector-length fids)))
      (when (not (zero? fid))
	(when (bit-vector-ref fids (sub1 fid))
	  (9p:file-close (make-9p:handle con (sub1 fid) 0 #f)))
	(loop (sub1 fid))))))

;; File IDs and handles
(define-record 9p:handle
  connection fid position iounit)

(define (initialize-iounit! h iounit)
  (9p:handle-iounit-set!
   h
   (if (zero? iounit)
       ;; 23 is the biggest size of a message (write), but libixp uses 24, so we do too to stay safe
       (- (9p:connection-message-size (9p:handle-connection h)) 24)
       iounit)))

;; Allocate the lowest fid that's not in use yet and return a handle to it
(define (9p:alloc-handle con)
  (let loop ((fids (9p:connection-open-fids con))
	     (highest 0))
    (cond
     ((bit-vector-full? fids (add1 highest))
      (loop fids (add1 highest)))
     ((>= highest 9p:nofid)
      (error "Out of file ids"))
     (else
      (9p:connection-open-fids-set! con (bit-vector-set! fids highest #t))
      (make-9p:handle con highest 0 #f)))))

;; Deallocate the given handle from the list (does _not_ clunk it)
(define (9p:release-handle h)
  (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))
  ;; Invalidate the handle
  (9p:handle-connection-set! h #f)
  (9p:handle-fid-set! h #f)
  (9p:handle-iounit-set! h #f)
  (void))

;; Make a list of path components.  Accepts either a string which it will split
;; at slashes, or a pre-made path component list.
(define (9p:normalize-path path)
  (if (pair? path)
      path
      (string-split path "/")))

;; Obtain a new fid
(define (9p:path-walk con path . rest)
  (let-optionals rest ((starting-point 0))
    (let ((new-handle (9p:alloc-handle con)))
      (handle-exceptions exn (begin (9p:release-handle new-handle) (signal exn))
	(9p:request con 'Twalk starting-point (9p:handle-fid new-handle) (9p:normalize-path path))
	new-handle))))

(define (9p:file-open con name mode)
  (let ((h (9p:path-walk con name)))
    (handle-exceptions exn (begin (9p:file-close h) (signal exn))
     (let* ((response (9p:request con 'Topen (9p:handle-fid h) mode))
	    (iounit (second (9p:message-contents response))))
       (initialize-iounit! h iounit)
       h))))

;; Clunk a fid
(define (9p:file-close h)
  (when (9p:handle-connection h) ; Ignore invalid handles (if already closed, closing again is ok)
   (9p:request (9p:handle-connection h) 'Tclunk (9p:handle-fid h))
   (9p:release-handle h)))

;; With a temporary handle to a file, perform some other procedure
;; The handle gets walked to and clunked automatically
(define (9p:with-handle-to con path procedure)
  (let ((h (9p:path-walk con path)))
    (handle-exceptions
     exn
     (begin
       (9p:file-close h)
       (signal exn)) ;; Just reraise it
     (let ((result (call-with-values (lambda () (procedure h)) list)))
       (9p:file-close h)
       (apply values result)))))

;; This is a hack, as the server might return other errors beside "file does not exist",
;; but there's no way we can really ask this question otherwise.
(define (9p:file-exists? con path)
  (condition-case (9p:with-handle-to con path (constantly #t))
    ((exn 9p-server-error) #f)))

;; This duplicates much of with-handle-to, but 9p isn't very consistent here: the
;; fid that initially represents the directory is now reused and represents the
;; newly created file, so we can't use with-handle-to (or we'd have to reopen the
;; file after creating, which is not possible in case of tempfiles)
(define (9p:file-create con name perm mode)
  (let ((h (9p:path-walk con (pathname-directory name))))
    (handle-exceptions
     exn
     (begin
       (9p:file-close h)
       (signal exn)) ;; Just reraise it
     (let* ((response (9p:request con 'Tcreate (9p:handle-fid h) (pathname-strip-directory name) perm mode))
	    (iounit (second (9p:message-contents response))))
       (initialize-iounit! h iounit)
       h))))

(define (u8vector-append! . vectors)
  (let* ((length (apply + (map u8vector-length vectors)))
	 (result (make-u8vector length)))
    (let next-vector ((vectors vectors)
		      (result-pos 0))
      (if (null? vectors)
	  result
	  (let next-pos ((vector-pos 0)
			 (result-pos result-pos))
	    (if (= vector-pos (u8vector-length (car vectors)))
		(next-vector (cdr vectors) result-pos)
		(begin
		  (u8vector-set! result result-pos (u8vector-ref (car vectors) vector-pos))
		  (next-pos (add1 vector-pos) (add1 result-pos)))))))))

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

;; TODO: Find a way to use an optional buffer to write in, so we don't end up
;; copying a whole lot of data around (overhead!)  -- file-write also has this
;; This is doubly bad because if we have a small message size the copying and
;; appending really becomes a whole lot of overhead.
(define (9p:file-read h size)
  (let loop ((bytes-left size)
	     (total 0)
	     (result (list)))
    (if (zero? bytes-left)
	(list (blob->string (u8vector->blob/shared (apply u8vector-append! (reverse result)))) total) ; file-read also returns a list of data + length
	(let* ((pos (9p:handle-position h))
	       (receive-size (min bytes-left (9p:handle-iounit h)))
	       (response (9p:request (9p:handle-connection h) 'Tread (9p:handle-fid h) pos receive-size))
	       (data (car (9p:message-contents response)))
	       (read (u8vector-length data)))
	  (cond
	   ((zero? read)
	    (loop 0 total (cons (make-u8vector bytes-left (char->integer #\space)) result))) ; Pad with empty u8vector, just like file-read
	   ((> read bytes-left)	; Sometimes the server returns more than we asked for! (when accidentally reading a dir, for example)
	    (9p:handle-position-set! h (+ pos bytes-left))
	    (loop 0 (+ total bytes-left) (cons (u8vector-slice data 0 bytes-left) result)))
	   (else
	    (9p:handle-position-set! h (+ pos read))
	    (loop (- bytes-left read) (+ total read) (cons data result))))))))

(define (9p:file-write h buffer . rest)
  (let ((buffer (if (string? buffer)
		    (blob->u8vector/shared (string->blob buffer))
		    buffer)))
    (let-optionals rest ((size (u8vector-length buffer)))
      (let loop ((bytes-left size)
		 (total 0))
	(if (zero? bytes-left)
	    total
	    (let* ((pos (9p:handle-position h))
		   (send-size (min bytes-left (9p:handle-iounit h)))
		   (response (9p:request (9p:handle-connection h) 'Twrite (9p:handle-fid h) pos (u8vector-slice buffer total send-size)))
		   (written (car (9p:message-contents response))))
	      (9p:handle-position-set! h (+ pos written))
	      (if (not (= written send-size))
		  (server-error 'Twrite (sprintf "Unexpected bytecount ~A instead of ~A in Rwrite response (not a proper server error message)" written send-size)))
	      (loop (- bytes-left written) (+ total written))))))))

; (qid permission-mode time time filesize string string string string)
(define (9p:handle-stat h)
  (apply values (9p:message-contents (9p:request (9p:handle-connection h) 'Tstat (9p:handle-fid h)))))

(define (9p:file-stat con file)
  (9p:with-handle-to
   con file 9p:handle-stat))

(define (9p:file-permissions con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 1))))

(define (9p:file-access-time con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 2))))

(define (9p:file-modification-time con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 3))))

;; There is no file-change-time because the protocol does not provide it.

(define (9p:file-size con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 4))))

;; 5 is file-name, which is rather silly

;;; Important: The following three procedures return _strings_, not IDs
(define (9p:file-owner con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 6))))

(define (9p:file-group con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 7))))

(define (9p:file-last-modified-by con file)
  (call-with-values
      (lambda () (9p:file-stat con file))
    (lambda l (list-ref l 8))))

(define (9p:directory? con path)
  (let ((new-handle (9p:alloc-handle con)))
    (handle-exceptions exn (begin (9p:release-handle new-handle) (signal exn))
     (let* ((response (9p:request con 'Twalk 0 (9p:handle-fid new-handle) (9p:normalize-path path)))
	    (is-dir (not (zero? (bitwise-and 9p:qtdir (9p:qid-type (last (9p:message-contents response))))))))
       (9p:file-close new-handle)
       is-dir))))

;; TODO: Find out if this is enough.  9p supports no symlinks?
(define (9p:regular-file? con file)
  (not (9p:directory? con file)))

(define (9p:set-file-position! h pos . rest)
  (let-optionals rest ((whence seek/set))
    (cond
     ((< 0 pos) (signal (make-composite-condition
			 (make-property-condition 'exn 'message (sprintf "Invalid negative seek position: ~S" pos))
			 (make-property-condition 'bounds))))
     ((eq? whence seek/set)
      (9p:handle-position-set! h pos))
     ((eq? whence seek/cur)
      (9p:handle-position-set! h (+ (9p:handle-position h) pos)))
     ((eq? whence seek/end)
      (let ((size (call-with-values
		      (lambda () (9p:handle-stat h))
		    (lambda l (list-ref 4)))))
	((9p:handle-position-set! h (+ size pos)))))
     (else (error (sprintf "Unknown seek position type (WHENCE value): ~S" whence))))))

(define 9p:file-position 9p:handle-position)

(define (read-directory h show-dotfiles?)
  (let loop ((result (list))
	     (pos 0))
    (let* ((response (9p:request (9p:handle-connection h) 'Tread (9p:handle-fid h) pos (9p:handle-iounit h)))
	   (data (car (9p:message-contents response)))
	   (read (u8vector-length data)))
      (if (zero? read)
	  (9p:data->directory-listing (apply u8vector-append! (reverse result)) show-dotfiles?)
	  (loop (cons data result) (+ pos read))))))

(define (9p:directory con file . rest)
  (let-optionals rest ((show-dotfiles? #f))
   (9p:with-handle-to
    con file
    (lambda (h)
      (call-with-values
	  (lambda () (9p:handle-stat h))
	(lambda l
	  (if (zero? (bitwise-and 9p:dmdir (list-ref l 1)))
	      (signal (make-composite-condition
		       (make-property-condition 'exn 'message (sprintf "~S is not a directory!" file))
		       (make-property-condition 'file)))
	      (let* ((response (9p:request con 'Topen (9p:handle-fid h) 9p:open/rdonly))
		     (iounit (second (9p:message-contents response))))
		(initialize-iounit! h iounit)
		(read-directory h show-dotfiles?)))))))))

(define (9p:delete-file con path)
  (let ((h (9p:path-walk con path)))
    (handle-exceptions exn (begin (9p:release-handle h) (signal exn))
      (9p:request con 'Tremove (9p:handle-fid h)) (9p:release-handle h))))

(define (9p:open-output-file con file . rest)
  (let ((h (if (9p:file-exists? con file)
	       (9p:file-open con file 9p:open/wronly)
	       (let-optionals rest ((mode (bitwise-ior 9p:perm/irusr 9p:perm/iwusr
						       9p:perm/irgrp 9p:perm/iwgrp
						       9p:perm/iroth 9p:perm/iwoth)))
			      (9p:file-create con file 9p:open/wronly mode)))))
    (make-output-port (lambda (s) (9p:file-write h s)) (lambda () (9p:file-close h)))))

(define (9p:call-with-output-file con file procedure)
  (let ((p (9p:open-output-file con file)))
    (handle-exceptions exn (begin (close-output-port p) (signal exn))
      (let ((result (procedure p)))
	(close-output-port p)
	result))))

(define (9p:with-output-to-file con file thunk)
  (9p:call-with-output-file con file (lambda (p) (parameterize ((current-output-port p)) (thunk)))))

(define (9p:open-input-file con file)
  (let* ((h (9p:file-open con file 9p:open/rdonly))
	 (buffer #f)
	 (buffer-offset 0)
	 (buffer-size 0))
    (make-input-port (lambda ()
		       ; This procedure does some string/blob/u8vector gymnastics so it returns raw
		       ; byte characters both when utf8 is loaded and when it's not.
		       ; The highlevel "read" procedures are overridden by utf8, but low-level
		       ; procedures are still expected to return byte-chars.  That's why we can't
		       ; use string-ref here (because it may really be utf8's string-ref).
		       (if buffer
			   (let ((char (integer->char (u8vector-ref buffer buffer-offset))))
			    (set! buffer-offset (add1 buffer-offset))
			    (when (= buffer-offset buffer-size)
				  (set! buffer-offset 0)
				  (set! buffer #f))
			    char)
			   (let ((result (9p:file-read h (min 1024 (9p:handle-iounit h)))))
			     (cond
			      ((zero? (second result)) #!eof)
			      ((= (second result) 1) (integer->char (u8vector-ref (blob->u8vector/shared (string->blob (car result))) 0)))
			      (else (set! buffer (blob->u8vector/shared (string->blob (car result))))
				    (set! buffer-size (second result))
				    (set! buffer-offset 1)
				    (integer->char (u8vector-ref buffer 0)))))))
		     (constantly #t)
		     (lambda ()
		       (9p:file-close h)))))

(define (9p:call-with-input-file con file procedure)
  (let* ((p (9p:open-input-file con file))
	 (result (procedure p)))
    (close-input-port p)
    result))

(define (9p:with-input-from-file con file thunk)
  (9p:call-with-input-file con file (lambda (p) (parameterize ((current-input-port p)) (thunk)))))