cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-02 04:36:43 +01:00
Code Issues

- added a draft for a kami client.

Browse Source
This commit is contained in:
cage 2022-01-09 14:47:22 +01:00
parent 97e83bf75d
commit b4ecbe49b0
8 changed files with 232 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
etc/init.lisp
View File

@ -137,7 +137,7 @@
;; global keymap ;; 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 (define-key "q" #'quit) ; here we are calling the custom
; function defined above ; function defined above
@ -600,7 +600,7 @@
(define-key "c" #'file-explorer-close-path *filesystem-explorer-keymap*) (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*) (define-key "D" #'file-explorer-delete-tree *filesystem-explorer-keymap*)

50
src/filesystem-tree-window.lisp
View File

@ -92,10 +92,36 @@
:type function :type function
:documentation "function with two parameter the path and a feature :documentation "function with two parameter the path and a feature
to query Valid feature values are :size. Returns nil if Returns to query Valid feature values are :size. Returns nil if Returns
nil if the path does not point to an actual file.")) nil if the path does not point to an actual file.")
(:documentation "A window that shows and allow interacting with a (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")) 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)) (defmethod refresh-config :after ((object filesystem-tree-window))
(with-croatoan-window (croatoan-window object) (with-croatoan-window (croatoan-window object)
(refresh-config-colors object swconf:+key-file-explorer+) (refresh-config-colors object swconf:+key-file-explorer+)
@ -213,11 +239,11 @@
(return-from write-loop t)))))) (return-from write-loop t))))))
destination-file) 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 (with-open-file (input-stream source-path
:direction :input :direction :input
:element-type +octect-type+) :element-type +octect-type+)
(with-open-file (output-stream (tree-path (data matching-node)) (with-open-file (output-stream destination-path
:direction :output :direction :output
:if-exists :supersede :if-exists :supersede
:if-does-not-exist :create :if-does-not-exist :create
@ -229,8 +255,7 @@
do do
(write-sequence buffer output-stream :start 0 :end read-so-far) (write-sequence buffer output-stream :start 0 :end read-so-far)
(when (< read-so-far +download-buffer+) (when (< read-so-far +download-buffer+)
(return-from write-loop t)))))) (return-from write-loop t)))))))
(tree-path (data matching-node)))
(defun %expand-treenode (root path-to-expand expand-fn) (defun %expand-treenode (root path-to-expand expand-fn)
(when-let ((matching-node (find-node root path-to-expand))) (when-let ((matching-node (find-node root path-to-expand)))
@ -387,11 +412,11 @@
(defun upload-treenode (window source-file remote-path) (defun upload-treenode (window source-file remote-path)
(when-let* ((root-node (filesystem-root window)) (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-node (find-node root-node (fs:parent-dir-path remote-path)))
(parent-path (tree-path (data parent-node)))) (parent-path (tree-path (data parent-node)))
(funcall (filesystem-upload-function window) source-file matching-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) (remove-all-children parent-node)
(expand-treenode window parent-path) (expand-treenode window parent-path)
(win-clear window :redraw nil) (win-clear window :redraw nil)
@ -510,7 +535,7 @@
(upload-treenode window (upload-treenode window
downloaded-path downloaded-path
node-path))))) node-path)))))
(defun init (root) (defun init (root &optional (handlers-plist nil))
"Initialize the window" "Initialize the window"
(let* ((low-level-window (make-croatoan-window :border t)) (let* ((low-level-window (make-croatoan-window :border t))
(high-level-window (make-instance 'filesystem-tree-window (high-level-window (make-instance 'filesystem-tree-window
@ -519,7 +544,8 @@
:key-config swconf:+key-keybindings-window+ :key-config swconf:+key-keybindings-window+
:keybindings *filesystem-explorer-keymap* :keybindings *filesystem-explorer-keymap*
:croatoan-window low-level-window :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) (refresh-config high-level-window)
(setf *filesystem-explorer-window* high-level-window) (setf *filesystem-explorer-window* high-level-window)
(resync-rows-db high-level-window :redraw t :selected-path root) (resync-rows-db high-level-window :redraw t :selected-path root)

7
src/filesystem-utils.lisp
View File

@ -257,6 +257,13 @@
(t (t
path)))) 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) (defmacro define-stat-time (slot-name)
(with-gensyms (stat) (with-gensyms (stat)
`(defun ,(format-symbol t "~:@(get-stat-~a~)" slot-name) (file) `(defun ,(format-symbol t "~:@(get-stat-~a~)" slot-name) (file)

1
src/gemini/package.lisp
View File

@ -154,6 +154,7 @@
:close-ssl-socket :close-ssl-socket
:make-client-certificate :make-client-certificate
:debug-gemini :debug-gemini
:open-tls-socket
:request :request
:gemini-file-stream-p :gemini-file-stream-p
:text-file-stream-p :text-file-stream-p

154
src/kami/client.lisp
View File

@ -1 +1,155 @@
(in-package :kami) (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))))))

8
src/kami/package.lisp
View File

@ -3,5 +3,9 @@
:cl :cl
:config :config
:constants :constants
:purgatory) :mtree
(:export)) :filesystem-tree-window)
(:local-nicknames (:9p :purgatory)
(:a :alexandria))
(:export
:generate-filesystem-window-handlers))

6
src/package.lisp
View File

@ -299,6 +299,7 @@
:path-first-element :path-first-element
:path-to-hidden-file-p :path-to-hidden-file-p
:parent-dir-path :parent-dir-path
:append-file-to-path
:strip-dirs-from-path :strip-dirs-from-path
:get-stat-mtime :get-stat-mtime
:get-stat-ctime :get-stat-ctime
@ -2027,6 +2028,10 @@
(:shadowing-import-from :text-utils :split-lines) (:shadowing-import-from :text-utils :split-lines)
(:shadowing-import-from :misc :random-elt :shuffle) (:shadowing-import-from :misc :random-elt :shuffle)
(:export (:export
:+octect-type+
:+download-buffer+
:make-temporary-file-from-node
:make-node-data
:filesystem-tree-window :filesystem-tree-window
:filesystem-root :filesystem-root
:tree-path :tree-path
@ -2798,6 +2803,7 @@
:load-script-file :load-script-file
:view-user-avatar :view-user-avatar
:open-file-explorer :open-file-explorer
:open-remote-file-explorer
:file-explorer-expand-path :file-explorer-expand-path
:file-explorer-close-path :file-explorer-close-path
:file-explorer-rename-path :file-explorer-rename-path

27
src/ui-goodies.lisp
View File

@ -2420,6 +2420,17 @@ printed, on the main window."
(filesystem-tree-window:init actual-root) (filesystem-tree-window:init actual-root)
(focus-to-filesystem-explorer-window)))) (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 () (defun file-explorer-expand-path ()
(when-let* ((win *filesystem-explorer-window*) (when-let* ((win *filesystem-explorer-window*)
(fields (line-oriented-window:selected-row-fields win)) (fields (line-oriented-window:selected-row-fields win))
@ -2482,7 +2493,7 @@ printed, on the main window."
"Upload a file" "Upload a file"
(when-let* ((win *filesystem-explorer-window*) (when-let* ((win *filesystem-explorer-window*)
(fields (line-oriented-window:selected-row-fields win)) (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) (labels ((build-actual-destination-file (source destination)
(if (fs:extension-dir-p destination) (if (fs:extension-dir-p destination)
(fs:cat-parent-dir destination (fs:cat-parent-dir destination
@ -2495,17 +2506,15 @@ printed, on the main window."
((not (fs:file-exists-p source-file)) ((not (fs:file-exists-p source-file))
(error-message (format nil "~a does not exists" source-file))) (error-message (format nil "~a does not exists" source-file)))
(t (t
(when (and (string-not-empty-p source-file) (when (string-not-empty-p source-file)
(not (fs:dirp destination-file)))
(with-enqueued-process () (with-enqueued-process ()
(with-blocking-notify-procedure (with-blocking-notify-procedure
((format nil (_ "Starting upload of ~a") source-file) ((format nil (_ "Starting upload of ~a") source-file)
(format nil (_ "Upload completed in ~a") destination-file)) (format nil (_ "Upload completed in ~a") destination-dir))
(fstree:upload-treenode win (let ((destination-file (build-actual-destination-file source-file
source-file destination-dir)))
(build-actual-destination-file source-file (fstree:upload-treenode win source-file destination-file)
destination-file)) (info-message destination-file)))))))))
(info-message destination-file))))))))
(ask-string-input #'on-input-complete (ask-string-input #'on-input-complete
:prompt (_ "Upload: ") :prompt (_ "Upload: ")
:complete-fn #'complete:directory-complete)))) :complete-fn #'complete:directory-complete))))