mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-02 04:36:43 +01:00
- added a draft for a kami client.
This commit is contained in:
cage
parent
97e83bf75d
commit
b4ecbe49b0
@ -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*)
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -154,6 +154,7 @@
|
||||
:close-ssl-socket
|
||||
:make-client-certificate
|
||||
:debug-gemini
|
||||
:open-tls-socket
|
||||
:request
|
||||
:gemini-file-stream-p
|
||||
:text-file-stream-p
|
||||
|
||||
@ -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))))))
|
||||
|
||||
@ -3,5 +3,9 @@
|
||||
:cl
|
||||
:config
|
||||
:constants
|
||||
:purgatory)
|
||||
(:export))
|
||||
:mtree
|
||||
:filesystem-tree-window)
|
||||
(:local-nicknames (:9p :purgatory)
|
||||
(:a :alexandria))
|
||||
(:export
|
||||
:generate-filesystem-window-handlers))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user