mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-21 08:50:51 +01:00
- [GUI] fitted titan protocol into the interface.
This commit is contained in:
cage
parent
0188d2f351
commit
e3df48e1a6
@ -190,6 +190,8 @@
|
||||
:debug-gemini
|
||||
:open-tls-socket
|
||||
:request
|
||||
:make-titan-query
|
||||
:parse-titan-query
|
||||
:titan-request
|
||||
:gemini-file-stream-p
|
||||
:text-file-stream-p
|
||||
|
||||
@ -149,13 +149,13 @@
|
||||
(inner-entry-key (gui-mw:autocomplete-entry-widget key-entry))
|
||||
(url-label (make-instance 'gui:label
|
||||
:master object
|
||||
:text "Gemini address"))
|
||||
:text (_ "Gemini address")))
|
||||
(cert-label (make-instance 'gui:label
|
||||
:master object
|
||||
:text "Certificate file"))
|
||||
:text (_ "Certificate file")))
|
||||
(key-label (make-instance 'gui:label
|
||||
:master object
|
||||
:text "Key file"))
|
||||
:text (_ "Key file")))
|
||||
(buttons-frame (make-instance 'gui:frame
|
||||
:master object)))
|
||||
(setf certificate-choose-button
|
||||
@ -170,7 +170,7 @@
|
||||
:master object
|
||||
:command (on-file-choosen-clsr inner-entry-key object)))
|
||||
(setf ok-button (make-instance 'gui:button
|
||||
:text "OK"
|
||||
:text (_ "OK")
|
||||
:master buttons-frame
|
||||
:command
|
||||
(import-certificate-clsr object certificate-frame)))
|
||||
|
||||
@ -42,7 +42,9 @@
|
||||
|
||||
(a:define-constant +gemlog-unsubscribe+ "fmw_rss-delete.png" :test #'string=)
|
||||
|
||||
(a:define-constant +inline-images+ "fmw_two-pictures.png" :test #'string=)
|
||||
(a:define-constant +inline-images+ "fmw_two-pictures.png" :test #'string=)
|
||||
|
||||
(a:define-constant +text+ "fmw_text.png" :test #'string=)
|
||||
|
||||
(defparameter *search* nil)
|
||||
|
||||
@ -86,6 +88,8 @@
|
||||
|
||||
(defparameter *inline-images* nil)
|
||||
|
||||
(defparameter *text* nil)
|
||||
|
||||
(defun load-icon (filename)
|
||||
(let ((path (if (not (re:scan "(?i)png$" filename))
|
||||
(res:get-data-file (fs:cat-parent-dir +icon-dir+
|
||||
@ -116,4 +120,5 @@
|
||||
(setf *dice* (load-icon +dice+))
|
||||
(setf *gemlog-subscribe* (load-icon +gemlog-subscribe+))
|
||||
(setf *gemlog-unsubscribe* (load-icon +gemlog-unsubscribe+))
|
||||
(setf *inline-images* (load-icon +inline-images+)))
|
||||
(setf *inline-images* (load-icon +inline-images+))
|
||||
(setf *text* (load-icon +text+)))
|
||||
|
||||
@ -117,7 +117,7 @@
|
||||
(aborting-function (constantly nil)))
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(set-focus-to-gemtext main-window))
|
||||
(enqueue-request-notify-error :gemini-request 1 iri use-cache)
|
||||
(enqueue-request-notify-error :gemini-request 1 iri use-cache nil)
|
||||
(labels ((stream-exausted-p ()
|
||||
(let ((status-completed (comm:make-request :gemini-stream-completed-p
|
||||
1
|
||||
@ -342,7 +342,8 @@
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri
|
||||
t)))
|
||||
t
|
||||
nil)))
|
||||
(multiple-value-bind (status-code
|
||||
status-description
|
||||
meta
|
||||
@ -822,6 +823,8 @@
|
||||
(funcall (menu:show-bookmarks-clsr main-window)))
|
||||
((iri:iri= iri (internal-iri-gemlogs))
|
||||
(menu:manage-gemlogs))
|
||||
((gemini-client:absolute-titan-url-p iri)
|
||||
(client-titan-window:init-window main-window iri))
|
||||
((gemini-parser:gemini-iri-p iri)
|
||||
(start-stream-iri (iri-ensure-path iri)
|
||||
main-window
|
||||
@ -918,7 +921,8 @@
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri
|
||||
use-cache)))
|
||||
use-cache
|
||||
nil)))
|
||||
(multiple-value-bind (status-code
|
||||
status-description
|
||||
meta
|
||||
|
||||
192
src/gui/client/titan-window.lisp
Normal file
192
src/gui/client/titan-window.lisp
Normal file
@ -0,0 +1,192 @@
|
||||
(in-package :client-titan-window)
|
||||
|
||||
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
||||
|
||||
(defclass titan-frame (gui:frame)
|
||||
((url-entry
|
||||
:initform nil
|
||||
:initarg :url-entry
|
||||
:accessor url-entry)
|
||||
(token-entry
|
||||
:initform nil
|
||||
:initarg :token-entry
|
||||
:accessor token-entry)
|
||||
(file-choose-button
|
||||
:initform nil
|
||||
:initarg :file-choose-button
|
||||
:accessor file-choose-button)
|
||||
(add-text-button
|
||||
:initform nil
|
||||
:initarg :add-text-button
|
||||
:accessor add-text-button)
|
||||
(file-chosen
|
||||
:initform nil
|
||||
:initarg :file-chosen
|
||||
:accessor file-chosen)
|
||||
(data-text
|
||||
:initform nil
|
||||
:initarg :data-text
|
||||
:accessor data-text)
|
||||
(ok-button
|
||||
:initform nil
|
||||
:initarg :ok-button
|
||||
:accessor ok-button)
|
||||
(cancel-button
|
||||
:initform nil
|
||||
:initarg :cancel-button
|
||||
:accessor cancel-button)))
|
||||
|
||||
(defun on-file-choosen-clsr (titan-frame &optional (initial-dir nil))
|
||||
(lambda ()
|
||||
(when (string-empty-p (trim-blanks (gui:text (data-text titan-frame))))
|
||||
(a:when-let ((current-file-chosen (file-chosen titan-frame)))
|
||||
(setf initial-dir (fs:parent-dir-path current-file-chosen)))
|
||||
(let ((new-file-path (gui:get-open-file :initial-dir initial-dir
|
||||
:parent titan-frame
|
||||
:multiple nil
|
||||
:title (_ "Choose the file"))))
|
||||
(setf (file-chosen titan-frame) new-file-path
|
||||
(gui:text (file-choose-button titan-frame)) new-file-path)))))
|
||||
|
||||
(defun launch-titan-request-clsr (frame)
|
||||
(lambda ()
|
||||
(with-accessors ((url-entry url-entry)
|
||||
(token-entry token-entry)
|
||||
(data-text data-text)
|
||||
(file-chosen file-chosen)) frame
|
||||
(let* ((send-file-p (and (string-not-empty-p file-chosen)
|
||||
(fs:file-exists-p file-chosen)))
|
||||
(base-url (gui:text url-entry))
|
||||
(url (iri:iri-parse base-url))
|
||||
(mime nil)
|
||||
(size nil)
|
||||
(titan-data nil)
|
||||
(trimmed-data-text (trim-blanks (gui:text data-text)))
|
||||
(has-error-p nil))
|
||||
(if send-file-p
|
||||
(progn
|
||||
(setf mime (os-utils:file->mime-type file-chosen)
|
||||
size (fs:file-size file-chosen)
|
||||
titan-data file-chosen))
|
||||
(if (string-empty-p trimmed-data-text)
|
||||
(progn
|
||||
(setf has-error-p t)
|
||||
(gui-goodies:notify-request-error (_ "Neither a file to upload has been specified nor text data has been typed.")))
|
||||
(setf mime constants:+mime-type-text+
|
||||
size (length (gui:text data-text))
|
||||
titan-data (trim-blanks (gui:text data-text)))))
|
||||
(when (not has-error-p)
|
||||
(let ((query (gemini-client:make-titan-query mime size (gui:text token-entry))))
|
||||
(setf (uri:query url) query)
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(gui-goodies::with-notify-errors
|
||||
(gui-goodies:with-busy* (frame)
|
||||
(comm:make-request :titan-save-token
|
||||
1
|
||||
base-url
|
||||
(gui:text token-entry))
|
||||
(comm:make-request :gemini-request
|
||||
1
|
||||
(to-s url)
|
||||
nil
|
||||
titan-data)
|
||||
(client-main-window::print-info-message (_ "Data uploaded")))))))))))
|
||||
|
||||
(defmethod initialize-instance :after ((object titan-frame) &key (url "") &allow-other-keys)
|
||||
(with-accessors ((url-entry url-entry)
|
||||
(token-entry token-entry)
|
||||
(data-text data-text)
|
||||
(file-choose-button file-choose-button)
|
||||
(file-chosen file-chosen)
|
||||
(add-text-button add-text-button)
|
||||
(ok-button ok-button)
|
||||
(cancel-button cancel-button)) object
|
||||
(setf url-entry (make-instance 'gui:entry
|
||||
:master object
|
||||
:text (when (text-utils:string-not-empty-p url)
|
||||
url)))
|
||||
(let* ((screen-width-in-pixel (/ (gui:screen-width) 2))
|
||||
(font (gui:cget url-entry :font))
|
||||
(zero-char-width (gui:font-measure font "0"))
|
||||
(entries-width (truncate (/ screen-width-in-pixel zero-char-width)))
|
||||
(saved-token (when (text-utils:string-not-empty-p url)
|
||||
(cev:enqueue-request-and-wait-results :titan-saved-token
|
||||
1
|
||||
ev:+standard-event-priority+
|
||||
url)))
|
||||
(url-label (make-instance 'gui:label
|
||||
:master object
|
||||
:text (_ "Titan address")))
|
||||
(token-label (make-instance 'gui:label
|
||||
:master object
|
||||
:text (_ "Access token")))
|
||||
(data-label (make-instance 'gui:label
|
||||
:master object
|
||||
:text (_ "Data to send")))
|
||||
(action-button-frame (make-instance 'gui:frame :master object))
|
||||
(data-source-button-frame (make-instance 'gui:frame :master object))
|
||||
(horizontal-padding (truncate (* screen-width-in-pixel 1/20)))
|
||||
(vertical-padding (truncate (/ horizontal-padding 10))))
|
||||
(setf token-entry
|
||||
(make-instance 'gui:entry
|
||||
:master object
|
||||
:text saved-token))
|
||||
(setf data-text
|
||||
(make-instance 'gui:scrolled-text
|
||||
:master object))
|
||||
(gui:configure url-entry :width entries-width)
|
||||
(gui:configure data-text :width entries-width)
|
||||
(setf file-choose-button
|
||||
(make-instance 'gui:button
|
||||
:text (_ "Upload file")
|
||||
:image icons:*folder*
|
||||
:compound :bottom
|
||||
:master data-source-button-frame
|
||||
:command
|
||||
(on-file-choosen-clsr object ".")))
|
||||
(setf add-text-button
|
||||
(make-instance 'gui:button
|
||||
:text (_ "Insert text")
|
||||
:compound :bottom
|
||||
:image icons:*text*
|
||||
:master data-source-button-frame
|
||||
:command (lambda ()
|
||||
(when (string-empty-p file-chosen)
|
||||
(gui:grid data-label 5 0
|
||||
:sticky :ew :padx horizontal-padding)
|
||||
(gui:grid data-text 6 0
|
||||
:sticky :ew :padx horizontal-padding)))))
|
||||
(setf ok-button (make-instance 'gui:button
|
||||
:text "OK"
|
||||
:master action-button-frame
|
||||
:command
|
||||
(launch-titan-request-clsr object)))
|
||||
(setf cancel-button (make-instance 'gui:button
|
||||
:text (_ "Cancel")
|
||||
:master action-button-frame
|
||||
:command
|
||||
(lambda () (gui:exit-from-toplevel (gui:master object)))))
|
||||
(gui:grid url-label 0 0 :sticky :ew :padx horizontal-padding
|
||||
:pady vertical-padding)
|
||||
(gui:grid url-entry 1 0 :sticky :ew :padx horizontal-padding
|
||||
:pady vertical-padding)
|
||||
(gui:grid data-source-button-frame 2 0 :sticky :ew :padx horizontal-padding
|
||||
:pady vertical-padding)
|
||||
(gui:grid file-choose-button 0 0)
|
||||
(gui:grid add-text-button 0 1)
|
||||
(gui:grid token-label 3 0 :sticky :ew :padx horizontal-padding
|
||||
:pady vertical-padding)
|
||||
(gui:grid token-entry 4 0 :sticky :ew :padx horizontal-padding
|
||||
:pady vertical-padding)
|
||||
(gui:grid action-button-frame 7 0 :sticky :ew :padx horizontal-padding
|
||||
:pady vertical-padding)
|
||||
(gui:grid ok-button 0 0)
|
||||
(gui:grid cancel-button 0 1))))
|
||||
|
||||
(defun init-window (master &optional (titan-url nil))
|
||||
(gui:with-toplevel (toplevel :master master :title (_ "Titan request window"))
|
||||
(gui:transient toplevel master)
|
||||
(let* ((frame (make-instance 'titan-frame
|
||||
:url titan-url
|
||||
:master toplevel)))
|
||||
(gui:grid frame 0 0 :sticky :news))))
|
||||
@ -182,6 +182,7 @@
|
||||
(cons "iri" iri)))
|
||||
|
||||
(defun %gemini-request (url &key
|
||||
(titan-data nil)
|
||||
(certificate nil)
|
||||
(certificate-key nil)
|
||||
(use-cached-file-if-exists nil)
|
||||
@ -212,7 +213,14 @@
|
||||
(%gemini-request iri
|
||||
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
||||
:certificate-key cached-key
|
||||
:certificate cached-certificate))))
|
||||
:certificate cached-certificate)))
|
||||
(titan-upload-dispatch (url)
|
||||
(multiple-value-bind (mime size token)
|
||||
(gemini-client::parse-titan-query (uri:query (iri:iri-parse url)))
|
||||
(let ((actual-data (if (fs:file-exists-p titan-data)
|
||||
(fs:namestring->pathname titan-data)
|
||||
titan-data)))
|
||||
(values actual-data size mime token)))))
|
||||
(handler-case
|
||||
(gemini-client:with-request-dispatch-table ((:certificate-requested
|
||||
#'certificate-request-dispatch
|
||||
@ -223,8 +231,10 @@
|
||||
:redirect
|
||||
#'redirect-dispatch
|
||||
:success
|
||||
#'request-success-dispatched-fn)
|
||||
:ignore-warning t)
|
||||
#'request-success-dispatched-fn
|
||||
:titan-upload
|
||||
#'titan-upload-dispatch)
|
||||
:ignore-warning nil)
|
||||
(debug-gemini-gui "viewer requesting iri ~s" url)
|
||||
(let ((actual-iri (gemini-client:displace-iri (iri:iri-parse url))))
|
||||
(db:gemlog-mark-as-seen actual-iri)
|
||||
@ -273,8 +283,10 @@
|
||||
(condition (c)
|
||||
(error (_ "Error getting ~s: ~a") url c)))))
|
||||
|
||||
(defun gemini-request (iri use-cache)
|
||||
(%gemini-request iri :use-cached-file-if-exists use-cache))
|
||||
(defun gemini-request (iri use-cache titan-data)
|
||||
(%gemini-request iri
|
||||
:titan-data titan-data
|
||||
:use-cached-file-if-exists use-cache))
|
||||
|
||||
(defgeneric rearrange-for-encoding (object))
|
||||
|
||||
@ -534,3 +546,10 @@
|
||||
|
||||
(defun gemini-save-url-db-history (iri)
|
||||
(db:insert-in-history (ui:open-url-prompt) iri))
|
||||
|
||||
(defun titan-saved-token (url)
|
||||
(db:saved-titan-token url))
|
||||
|
||||
(defun titan-save-token (url token)
|
||||
(db:save-titan-token url token)
|
||||
t)
|
||||
|
||||
@ -42,8 +42,9 @@
|
||||
"hint" 0)
|
||||
(gen-rpc "gemini-request"
|
||||
'gemini-request
|
||||
"iri" 0
|
||||
"use-cache" 1)
|
||||
"iri" 0
|
||||
"use-cache" 1
|
||||
"titan-data" 2)
|
||||
(gen-rpc "gemini-stream-info"
|
||||
'gemini-stream-info
|
||||
"iri" 0)
|
||||
@ -56,7 +57,8 @@
|
||||
"iri" 0
|
||||
"line-number-start" 1
|
||||
"line-number-end" 2)
|
||||
(gen-rpc "gemini-all-stream-info" 'gemini-all-stream-info)
|
||||
(gen-rpc "gemini-all-stream-info"
|
||||
'gemini-all-stream-info)
|
||||
(gen-rpc "gemini-stream-status"
|
||||
'gemini-stream-status
|
||||
"iri" 0)
|
||||
@ -128,6 +130,11 @@
|
||||
"iri" 0
|
||||
"title" 1
|
||||
"subtitle" 2)
|
||||
(gen-rpc "titan-save-token" 'titan-save-token
|
||||
"url" 0
|
||||
"token" 1)
|
||||
(gen-rpc "titan-saved-token" 'titan-saved-token
|
||||
"url" 0)
|
||||
(gen-rpc "iri-to-parent-path" 'iri-to-parent-path "iri" 0)
|
||||
(gen-rpc "quit-program" 'quit-program)
|
||||
,@body))
|
||||
|
||||
@ -367,8 +367,8 @@
|
||||
:text
|
||||
(format nil
|
||||
"Number of parameters (arity) not compatible with function: expected ~a got ~a."
|
||||
(length (params request))
|
||||
(length (params fun)))))
|
||||
(length (params fun))
|
||||
(length (params request)))))
|
||||
(t
|
||||
(let* ((params (params request))
|
||||
(called-by-name-p (called-by-name-p fun params)))
|
||||
|
||||
@ -3379,7 +3379,8 @@
|
||||
:*dice*
|
||||
:*gemlog-subscribe*
|
||||
:*gemlog-unsubscribe*
|
||||
:*inline-images*))
|
||||
:*inline-images*
|
||||
:*text*))
|
||||
|
||||
(defpackage :validation
|
||||
(:use
|
||||
@ -3483,6 +3484,25 @@
|
||||
:rows
|
||||
:init-window))
|
||||
|
||||
(defpackage :client-titan-window
|
||||
(:use
|
||||
:cl
|
||||
:config
|
||||
:constants
|
||||
:text-utils
|
||||
:misc-utils)
|
||||
(:local-nicknames (:comm :json-rpc-communication)
|
||||
(:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:ev :program-events)
|
||||
(:cev :client-events)
|
||||
(:gui :nodgui)
|
||||
(:gui-mw :nodgui.mw)
|
||||
(:gui-shapes :nodgui.shapes)
|
||||
(:menu :client-menu-command))
|
||||
(:export
|
||||
:init-window))
|
||||
|
||||
(defpackage :client-tour-window
|
||||
(:use
|
||||
:cl
|
||||
|
||||
@ -170,6 +170,7 @@
|
||||
(:file "validation")
|
||||
(:file "icons")
|
||||
(:file "certificates-window")
|
||||
(:file "titan-window")
|
||||
(:file "tour-window")
|
||||
(:file "stream-window")
|
||||
(:file "bookmark-window")
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user