diff --git a/src/kami/client.lisp b/src/kami/client.lisp index bd5c664..9889b00 100644 --- a/src/kami/client.lisp +++ b/src/kami/client.lisp @@ -10,6 +10,11 @@ (defparameter *root-fid* nil) +(defstruct 9p-parameters + (message-sent) + (fid) + (tag)) + (defmacro with-open-ssl-stream ((ssl-stream socket host port client-certificate certificate-key) @@ -37,182 +42,203 @@ (when ,clunk-cloned-fid (9p:9p-clunk ,stream ,cloned-fid))))) -(defun expand-node (stream root-fid) - (lambda (node) - (let* ((*stream* stream) - (*root-fid* root-fid) - (path (tree-path (data node)))) - (with-cloned-root-fid (*stream* cloned-root-fid) - (let* ((entries (9p:collect-directory-children *stream* cloned-root-fid path)) - (files (remove-if-not (lambda (a) (or (eq (9p:stat-entry-type a) - :file) - (eq (9p:stat-entry-type a) - :executable))) - entries)) - (directories (remove-if-not (lambda (a) (eq (9p:stat-entry-type a) - :directory)) - entries))) - (remove-all-children node) - (loop for directory in directories do - (let ((absolute-path (text-utils:strcat path (9p:stat-name directory)))) - (add-child node - (make-instance 'm-tree - :data (make-node-data absolute-path t))))) - (loop for file in files do - (let ((absolute-path (text-utils:strcat path (9p:stat-name file)))) - (add-child node - (make-instance 'm-tree - :data (make-node-data absolute-path nil)))))))) - node)) +(defmacro with-9p-params ((params) &body body) + `(let* ((9p:*tag* (9p-parameters-tag ,params)) + (9p:*fid* (9p-parameters-fid ,params)) + (9p:*messages-sent* (9p-parameters-message-sent ,params))) + (unwind-protect + (progn ,@body) + (setf (9p-parameters-tag ,params) 9p:*tag*) + (setf (9p-parameters-fid ,params) 9p:*fid*) + (setf (9p-parameters-message-sent ,params) 9p:*messages-sent*)))) -(defun rename-node (stream root-fid) +(defun expand-node (stream root-fid params) + (lambda (node) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (with-cloned-root-fid (*stream* cloned-root-fid) + (let* ((entries (9p:collect-directory-children *stream* cloned-root-fid path)) + (files (remove-if-not (lambda (a) (or (eq (9p:stat-entry-type a) + :file) + (eq (9p:stat-entry-type a) + :executable))) + entries)) + (directories (remove-if-not (lambda (a) (eq (9p:stat-entry-type a) + :directory)) + entries))) + (remove-all-children node) + (loop for directory in directories do + (let ((absolute-path (text-utils:strcat path (9p:stat-name directory)))) + (add-child node + (make-instance 'm-tree + :data (make-node-data absolute-path t))))) + (loop for file in files do + (let ((absolute-path (text-utils:strcat path (9p:stat-name file)))) + (add-child node + (make-instance 'm-tree + :data (make-node-data absolute-path nil)))))) + node))))) + +(defun rename-node (stream root-fid params) (lambda (node new-path) - (let* ((*stream* stream) - (*root-fid* root-fid) - (path (tree-path (data node)))) - (assert path) - (with-cloned-root-fid (*stream* cloned-root-fid) - (9p:move-file *stream* cloned-root-fid path new-path))))) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (assert path) + (with-cloned-root-fid (*stream* cloned-root-fid) + (9p:move-file *stream* cloned-root-fid path new-path)))))) -(defun delete-node (stream root-fid) +(defun delete-node (stream root-fid params) (lambda (node) - (let* ((*stream* stream) - (*root-fid* root-fid) - (path (tree-path (data node)))) - (assert path) - (with-cloned-root-fid (*stream* cloned-root-fid) - (9p:remove-path *stream* cloned-root-fid path))))) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (assert path) + (with-cloned-root-fid (*stream* cloned-root-fid) + (9p:remove-path *stream* cloned-root-fid path)))))) -(defun create-node (stream root-fid) +(defun create-node (stream root-fid params) (lambda (path dirp) - (let* ((*stream* stream) - (*root-fid* root-fid)) - (assert path) - (with-cloned-root-fid (*stream* cloned-root-fid :clunk-cloned-fid nil) - (let ((created-fid nil)) - (if dirp - (setf created-fid - (9p:create-path *stream* - cloned-root-fid - (if (fs:path-referencing-dir-p path) - path - (text-utils:strcat path "/")))) - (setf created-fid - (9p:create-path *stream* cloned-root-fid path))) - (9p:9p-clunk *stream* created-fid)))))) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (assert path) + (with-cloned-root-fid (*stream* cloned-root-fid :clunk-cloned-fid nil) + (let ((created-fid nil)) + (if dirp + (setf created-fid + (9p:create-path *stream* + cloned-root-fid + (if (fs:path-referencing-dir-p path) + path + (text-utils:strcat path "/")))) + (setf created-fid + (9p:create-path *stream* cloned-root-fid path))) + (9p:9p-clunk *stream* created-fid))))))) -(defun download-node (stream root-fid) +(defun download-node (stream root-fid params) (lambda (node &optional (destination-file (make-temporary-file-from-node node))) - (let* ((*stream* stream) - (*root-fid* root-fid) - (path (tree-path (data node)))) - (with-open-file (output-stream destination-file - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :element-type +octect-type+) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (with-open-file (output-stream destination-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :element-type +octect-type+) + (with-cloned-root-fid (*stream* cloned-root-fid) + (9p:read-entire-file-apply-function stream + cloned-root-fid + path + (lambda (data offset count) + (declare (ignore offset count)) + (write-sequence data output-stream))))) (with-cloned-root-fid (*stream* cloned-root-fid) - (9p:read-entire-file-apply-function stream - cloned-root-fid - path - (lambda (data offset count) - (declare (ignore offset count)) - (write-sequence data output-stream))))) - (with-cloned-root-fid (*stream* cloned-root-fid) - (let* ((info-source-node (9p:path-info *stream* cloned-root-fid path)) - (permissions (9p:permissions-original-value (9p:stat-mode info-source-node))) - (destination-file-mode (logand permissions #x7ff))) - (fs:change-path-permissions destination-file destination-file-mode))) - destination-file))) + (let* ((info-source-node (9p:path-info *stream* cloned-root-fid path)) + (permissions (9p:permissions-original-value (9p:stat-mode info-source-node))) + (destination-file-mode (logand permissions #x7ff))) + (fs:change-path-permissions destination-file destination-file-mode))) + destination-file)))) -(defun upload-node (stream root-fid) +(defun upload-node (stream root-fid params) (lambda (source-path destination-path) - (let* ((*stream* stream) - (*root-fid* root-fid)) - (let ((source-permissions (fs:get-stat-mode source-path))) - (with-open-file (input-stream source-path - :direction :input - :element-type +octect-type+) - (with-cloned-root-fid (*stream* cloned-root-fid) - (9p:remove-path *stream* cloned-root-fid destination-path)) - (with-cloned-root-fid (*stream* cloned-root-fid :clunk-cloned-fid nil) - (let* ((buffer (misc:make-array-frame +download-buffer+ 0 +octect-type+ t)) - (fid (9p:create-path *stream* cloned-root-fid destination-path))) - (loop named write-loop - for read-so-far = (read-sequence buffer input-stream) - then (read-sequence buffer input-stream) - for offset = 0 then (+ offset read-so-far) - do - (9p:9p-write *stream* fid offset (subseq buffer 0 read-so-far)) - (when (< read-so-far +download-buffer+) - (return-from write-loop t))) - (9p:9p-clunk *stream* fid))) - (with-cloned-root-fid (*stream* cloned-root-fid) - (9p:change-mode *stream* - cloned-root-fid - destination-path source-permissions) - (9p:read-all-pending-messages stream))))))) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (let ((source-permissions (fs:get-stat-mode source-path))) + (with-open-file (input-stream source-path + :direction :input + :element-type +octect-type+) + (with-cloned-root-fid (*stream* cloned-root-fid) + (9p:remove-path *stream* cloned-root-fid destination-path)) + (with-cloned-root-fid (*stream* cloned-root-fid :clunk-cloned-fid nil) + (let* ((buffer (misc:make-array-frame +download-buffer+ 0 +octect-type+ t)) + (fid (9p:create-path *stream* cloned-root-fid destination-path))) + (loop named write-loop + for read-so-far = (read-sequence buffer input-stream) + then (read-sequence buffer input-stream) + for offset = 0 then (+ offset read-so-far) + do + (9p:9p-write *stream* fid offset (subseq buffer 0 read-so-far)) + (when (< read-so-far +download-buffer+) + (return-from write-loop t))) + (9p:9p-clunk *stream* fid))) + (with-cloned-root-fid (*stream* cloned-root-fid) + (9p:change-mode *stream* + cloned-root-fid + destination-path source-permissions) + (9p:read-all-pending-messages stream)))))))) -(defun query-path (stream root-fid) +(defun query-path (stream root-fid params) (lambda (path what) - (let* ((*stream* stream) - (*root-fid* root-fid)) - (with-cloned-root-fid (*stream* cloned-root-fid) - (a:when-let ((stat-entry (9p:path-info *stream* cloned-root-fid path))) - (ecase what - (:type - (9p:stat-entry-type stat-entry)) - (:size - (9p:stat-entry-type stat-entry)) - (:size-string - (fs:octects->units-string (9p:stat-size stat-entry))) - (:permissions-string - (let ((mode (9p:stat-mode stat-entry))) - (format nil - (_ "User: ~a Group: ~a Others ~a") - (9p:permissions-user-string mode) - (9p:permissions-group-string mode) - (9p:permissions-others-string mode)))))))))) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (with-cloned-root-fid (*stream* cloned-root-fid) + (a:when-let ((stat-entry (9p:path-info *stream* cloned-root-fid path))) + (ecase what + (:type + (9p:stat-entry-type stat-entry)) + (:size + (9p:stat-entry-type stat-entry)) + (:size-string + (fs:octects->units-string (9p:stat-size stat-entry))) + (:permissions-string + (let ((mode (9p:stat-mode stat-entry))) + (format nil + (_ "User: ~a Group: ~a Others ~a") + (9p:permissions-user-string mode) + (9p:permissions-group-string mode) + (9p:permissions-others-string mode))))))))))) -(defun collect-tree (stream root-fid) +(defun collect-tree (stream root-fid params) (lambda (path) - (let* ((*stream* stream) - (*root-fid* root-fid) - (all-files nil) - (all-dirs nil)) - (with-cloned-root-fid (*stream* cloned-root-fid :clunk-cloned-fid t) - (multiple-value-bind (files directories) - (9p:collect-tree *stream* cloned-root-fid path) - (setf all-files files) - (setf all-dirs directories))) - (values all-files all-dirs)))) + (with-9p-params (params) + (let* ((*stream* stream) + (*root-fid* root-fid) + (all-files nil) + (all-dirs nil)) + (with-cloned-root-fid (*stream* cloned-root-fid :clunk-cloned-fid t) + (multiple-value-bind (files directories) + (9p:collect-tree *stream* cloned-root-fid path) + (setf all-files files) + (setf all-dirs directories))) + (values all-files all-dirs))))) (defun generate-filesystem-window-handlers (path host port query fragment client-certificate client-key) - (setf 9p:*tag* 8) - (setf 9p:*fid* 1) - (setf 9p:*messages-sent* '()) (with-open-ssl-stream (stream socket host port client-certificate client-key) - (let* ((*stream* stream) - (*root-fid* (9p:mount *stream* "/"))) - (list :query query - :fragment fragment - :socket socket - :path path - :filesystem-expand-function (expand-node *stream* *root-fid*) - :filesystem-rename-function (rename-node *stream* *root-fid*) - :filesystem-delete-function (delete-node *stream* *root-fid*) - :filesystem-create-function (create-node *stream* *root-fid*) - :filesystem-download-function (download-node *stream* *root-fid*) - :filesystem-upload-function (upload-node *stream* *root-fid*) - :filesystem-query-path-function (query-path *stream* *root-fid*) - :filesystem-collect-tree (collect-tree *stream* *root-fid*) - :filesystem-close-connection-function (lambda () - (9p:close-client socket)))))) + (let* ((9p:*tag* 10) + (9p:*fid* 1) + (9p:*messages-sent* '()) + (*stream* stream) + (*root-fid* (9p:mount *stream* "/")) + (parameters (make-9p-parameters :message-sent 9p:*messages-sent* + :fid 9p:*fid* + :tag 9p:*tag*))) + (list :query query + :fragment fragment + :socket socket + :path path + :filesystem-expand-function (expand-node *stream* *root-fid* parameters) + :filesystem-rename-function (rename-node *stream* *root-fid* parameters) + :filesystem-delete-function (delete-node *stream* *root-fid* parameters) + :filesystem-create-function (create-node *stream* *root-fid* parameters) + :filesystem-download-function (download-node *stream* *root-fid* parameters) + :filesystem-upload-function (upload-node *stream* *root-fid* parameters) + :filesystem-query-path-function (query-path *stream* *root-fid* parameters) + :filesystem-collect-tree (collect-tree *stream* *root-fid* parameters) + :filesystem-close-connection-function (lambda () + (9p:close-client socket)))))) (defun iri->filesystem-window-handlers (kami-iri) (a:when-let ((parsed-iri (iri:iri-parse kami-iri :null-on-error t))) diff --git a/src/misc-utils.lisp b/src/misc-utils.lisp index 41f88ff..22499c9 100644 --- a/src/misc-utils.lisp +++ b/src/misc-utils.lisp @@ -118,7 +118,7 @@ (defun function-name (data) "Implementation dependent" (assert (functionp data)) - (conditions:with-default-on-error ((_ "Anonymous function")) + (conditions:with-default-on-error ((config:_ "Anonymous function")) (multiple-value-bind (x y name) (function-lambda-expression data) (declare (ignore x y))