diff --git a/etc/init.lisp b/etc/init.lisp index 2587101..ecf2fc7 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -137,7 +137,7 @@ ;; global keymap -(define-key "y y" #'open-file-explorer) +(define-key "y y" #'open-remote-file-explorer) (define-key "q" #'quit) ; here we are calling the custom ; function defined above @@ -600,7 +600,7 @@ (define-key "c" #'file-explorer-close-path *filesystem-explorer-keymap*) -(define-key "m" #'file-explorer-rename-path *filesystem-explorer-keymap*) +(define-key "r" #'file-explorer-rename-path *filesystem-explorer-keymap*) (define-key "D" #'file-explorer-delete-tree *filesystem-explorer-keymap*) diff --git a/src/filesystem-tree-window.lisp b/src/filesystem-tree-window.lisp index 0f6fc2d..22a4833 100644 --- a/src/filesystem-tree-window.lisp +++ b/src/filesystem-tree-window.lisp @@ -92,10 +92,36 @@ :type function :documentation "function with two parameter the path and a feature to query Valid feature values are :size. Returns nil if Returns - nil if the path does not point to an actual file.")) - (:documentation "A window that shows and allow interacting with a + nil if the path does not point to an actual file.") + (filesystem-close-connection-function + :initform (lambda (stream) (declare (ignore stream))) + :accessor filesystem-close-connection-function + :type function + :documentation "function with a signle parameter the connection stream to be closed.")) + (:documentation "A window that shows and allow interacting with a hierarchical filesystem")) +(defmethod initialize-instance :after ((object filesystem-tree-window) + &key (handlers-plist nil) &allow-other-keys) + (when handlers-plist + (setf (filesystem-expand-function object) + (getf handlers-plist :filesystem-expand-function) + (filesystem-expand-function object) + (getf handlers-plist :filesystem-expand-function) + (filesystem-rename-function object) + (getf handlers-plist :filesystem-rename-function) + (filesystem-delete-function object) + (getf handlers-plist :filesystem-delete-function) + (filesystem-create-function object) + (getf handlers-plist :filesystem-create-function) + (filesystem-download-function object) + (getf handlers-plist :filesystem-download-function) + (filesystem-upload-function object) + (getf handlers-plist :filesystem-upload-function) + (filesystem-query-path-function object) + (getf handlers-plist :filesystem-query-path-function))) + object) + (defmethod refresh-config :after ((object filesystem-tree-window)) (with-croatoan-window (croatoan-window object) (refresh-config-colors object swconf:+key-file-explorer+) @@ -213,11 +239,11 @@ (return-from write-loop t)))))) destination-file) -(defun upload-local-filesystem-node (source-path matching-node) +(defun upload-local-filesystem-node (source-path destination-path) (with-open-file (input-stream source-path :direction :input :element-type +octect-type+) - (with-open-file (output-stream (tree-path (data matching-node)) + (with-open-file (output-stream destination-path :direction :output :if-exists :supersede :if-does-not-exist :create @@ -229,8 +255,7 @@ do (write-sequence buffer output-stream :start 0 :end read-so-far) (when (< read-so-far +download-buffer+) - (return-from write-loop t)))))) - (tree-path (data matching-node))) + (return-from write-loop t))))))) (defun %expand-treenode (root path-to-expand expand-fn) (when-let ((matching-node (find-node root path-to-expand))) @@ -387,11 +412,11 @@ (defun upload-treenode (window source-file remote-path) (when-let* ((root-node (filesystem-root window)) - (matching-node (find-node root-node remote-path)) - (filep (not (tree-dir-p (data matching-node)))) (parent-node (find-node root-node (fs:parent-dir-path remote-path))) - (parent-path (tree-path (data parent-node)))) - (funcall (filesystem-upload-function window) source-file matching-node) + (parent-path (tree-path (data parent-node))) + (destination-path (fs:append-file-to-path parent-path + (fs:path-last-element source-file)))) + (funcall (filesystem-upload-function window) source-file destination-path) (remove-all-children parent-node) (expand-treenode window parent-path) (win-clear window :redraw nil) @@ -510,7 +535,7 @@ (upload-treenode window downloaded-path node-path))))) -(defun init (root) +(defun init (root &optional (handlers-plist nil)) "Initialize the window" (let* ((low-level-window (make-croatoan-window :border t)) (high-level-window (make-instance 'filesystem-tree-window @@ -519,7 +544,8 @@ :key-config swconf:+key-keybindings-window+ :keybindings *filesystem-explorer-keymap* :croatoan-window low-level-window - :filesystem-root (make-root-tree root)))) + :filesystem-root (make-root-tree root) + :handlers-plist handlers-plist))) (refresh-config high-level-window) (setf *filesystem-explorer-window* high-level-window) (resync-rows-db high-level-window :redraw t :selected-path root) diff --git a/src/filesystem-utils.lisp b/src/filesystem-utils.lisp index 447d6e8..741c0d9 100644 --- a/src/filesystem-utils.lisp +++ b/src/filesystem-utils.lisp @@ -257,6 +257,13 @@ (t path)))) +(defun append-file-to-path (dir filename) + (let ((actual-dir (if (cl-ppcre:scan (concatenate 'string *directory-sep* "$") + dir) + dir + (concatenate 'string dir *directory-sep*)))) + (concatenate 'string actual-dir filename))) + (defmacro define-stat-time (slot-name) (with-gensyms (stat) `(defun ,(format-symbol t "~:@(get-stat-~a~)" slot-name) (file) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index 8c80e19..c14ee47 100644 --- a/src/gemini/package.lisp +++ b/src/gemini/package.lisp @@ -154,6 +154,7 @@ :close-ssl-socket :make-client-certificate :debug-gemini + :open-tls-socket :request :gemini-file-stream-p :text-file-stream-p diff --git a/src/kami/client.lisp b/src/kami/client.lisp index f12c9a6..028cca4 100644 --- a/src/kami/client.lisp +++ b/src/kami/client.lisp @@ -1 +1,155 @@ (in-package :kami) + +(a:define-constant +download-buffer+ (expt 2 24) :test #'=) + +(a:define-constant +octect-type+ '(unsigned-byte 8) :test #'equalp) + +(defparameter *stream* nil) + +(defparameter *root-fid* nil) + +(defmacro with-open-ssl-stream ((ssl-stream socket host port + client-certificate + certificate-key) + &body body) + (alexandria:with-gensyms (tls-context socket-stream ssl-hostname) + `(let ((,tls-context (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) + (cl+ssl:with-global-context (,tls-context :auto-free-p t) + (let* ((,socket (gemini-client:open-tls-socket ,host ,port)) + (,socket-stream (usocket:socket-stream ,socket)) + (,ssl-hostname ,host) + (,ssl-stream + (cl+ssl:make-ssl-client-stream ,socket-stream + :certificate ,client-certificate + :key ,certificate-key + :external-format nil ; unsigned byte 8 + :unwrap-stream-p t + :verify nil + :hostname ,ssl-hostname))) + ,@body))))) + +(defmacro with-cloned-root-fid ((stream cloned-fid) &body body) + `(let ((,cloned-fid (9p:clone-fid ,stream *root-fid*))) + ,@body)) + +(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* root-fid) + (a:when-let* ((entries (9p:collect-directory-children *stream* 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) + (lambda (node new-path) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (assert path) + (with-cloned-root-fid (*stream* root-fid) + (9p:move-file *stream* root-fid path new-path))))) + +(defun delete-node (stream root-fid) + (lambda (node) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (assert path) + (with-cloned-root-fid (*stream* root-fid) + (9p:remove-path *stream* root-fid path))))) + +(defun create-node (stream root-fid) + (lambda (path dirp) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (assert path) + (with-cloned-root-fid (*stream* root-fid) + (if dirp + (9p:create-path *stream* root-fid (if (cl-ppcre:scan "/$" path) + path + (text-utils:strcat path "/"))) + (9p:create-path *stream* root-fid path)))))) + +(defun download-node (stream root-fid) + (lambda (node + &optional + (destination-file + (make-temporary-file-from-node node))) + (let* ((*stream* stream) + (*root-fid* root-fid) + (path (tree-path (data node)))) + (with-cloned-root-fid (*stream* root-fid) + (let ((data (9p:slurp-file *stream* root-fid path))) + (with-open-file (output-stream destination-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :element-type +octect-type+) + (write-sequence data output-stream))))) + destination-file)) + +(defun upload-node (stream root-fid) + (lambda (source-path destination-path) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (with-open-file (input-stream source-path + :direction :input + :element-type +octect-type+) + (with-cloned-root-fid (*stream* root-fid) + (let* ((buffer (misc:make-array-frame +download-buffer+ 0 +octect-type+ t)) + (fid (9p:create-path *stream* 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) + (9p:read-all-pending-message stream))))))) + +(defun query-path (stream root-fid) + (lambda (path what) + (let* ((*stream* stream) + (*root-fid* root-fid)) + (ecase what + (:size + (with-cloned-root-fid (*stream* root-fid) + (a:when-let ((stat-entry (9p:path-exists-p *stream* root-fid path))) + (9p:stat-size stat-entry)))))))) + +(defun generate-filesystem-window-handlers (root host port client-certificate client-key) + (with-open-ssl-stream (stream socket host port client-certificate client-key) + (let* ((*stream* stream) + (*root-fid* (9p:mount *stream* root))) + (list :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-close-connection-function (lambda (stream) + (declare (ignore stream)) + (9p:close-client socket)))))) diff --git a/src/kami/package.lisp b/src/kami/package.lisp index 02883af..ff0bd18 100644 --- a/src/kami/package.lisp +++ b/src/kami/package.lisp @@ -3,5 +3,9 @@ :cl :config :constants - :purgatory) - (:export)) + :mtree + :filesystem-tree-window) + (:local-nicknames (:9p :purgatory) + (:a :alexandria)) + (:export + :generate-filesystem-window-handlers)) diff --git a/src/package.lisp b/src/package.lisp index c34ca67..6a1e6ad 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -299,6 +299,7 @@ :path-first-element :path-to-hidden-file-p :parent-dir-path + :append-file-to-path :strip-dirs-from-path :get-stat-mtime :get-stat-ctime @@ -2027,6 +2028,10 @@ (:shadowing-import-from :text-utils :split-lines) (:shadowing-import-from :misc :random-elt :shuffle) (:export + :+octect-type+ + :+download-buffer+ + :make-temporary-file-from-node + :make-node-data :filesystem-tree-window :filesystem-root :tree-path @@ -2798,6 +2803,7 @@ :load-script-file :view-user-avatar :open-file-explorer + :open-remote-file-explorer :file-explorer-expand-path :file-explorer-close-path :file-explorer-rename-path diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index e05ed79..efd6555 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -2420,6 +2420,17 @@ printed, on the main window." (filesystem-tree-window:init actual-root) (focus-to-filesystem-explorer-window)))) + +(defun open-remote-file-explorer (&optional (root "/")) + (with-enqueued-process () + (let ((handlers (kami:generate-filesystem-window-handlers root + *host* + *port* + *client-certificate* + *certificate-key*))) + (filesystem-tree-window:init root handlers) + (focus-to-filesystem-explorer-window)))) + (defun file-explorer-expand-path () (when-let* ((win *filesystem-explorer-window*) (fields (line-oriented-window:selected-row-fields win)) @@ -2482,7 +2493,7 @@ printed, on the main window." "Upload a file" (when-let* ((win *filesystem-explorer-window*) (fields (line-oriented-window:selected-row-fields win)) - (destination-file (fstree:tree-path fields))) + (destination-dir (fstree:tree-path fields))) (labels ((build-actual-destination-file (source destination) (if (fs:extension-dir-p destination) (fs:cat-parent-dir destination @@ -2495,17 +2506,15 @@ printed, on the main window." ((not (fs:file-exists-p source-file)) (error-message (format nil "~a does not exists" source-file))) (t - (when (and (string-not-empty-p source-file) - (not (fs:dirp destination-file))) + (when (string-not-empty-p source-file) (with-enqueued-process () (with-blocking-notify-procedure ((format nil (_ "Starting upload of ~a") source-file) - (format nil (_ "Upload completed in ~a") destination-file)) - (fstree:upload-treenode win - source-file - (build-actual-destination-file source-file - destination-file)) - (info-message destination-file)))))))) + (format nil (_ "Upload completed in ~a") destination-dir)) + (let ((destination-file (build-actual-destination-file source-file + destination-dir))) + (fstree:upload-treenode win source-file destination-file) + (info-message destination-file))))))))) (ask-string-input #'on-input-complete :prompt (_ "Upload: ") :complete-fn #'complete:directory-complete))))