mirror of https://codeberg.org/cage/tinmop/
240 lines
13 KiB
Common Lisp
240 lines
13 KiB
Common Lisp
(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)))
|
|
(a:when-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 trimmed-data-text)
|
|
titan-data trimmed-data-text)))
|
|
(when (not has-error-p)
|
|
(let ((parameters (gemini-client:make-titan-parameters mime size (gui:text token-entry))))
|
|
(setf (uri:path url) (strcat (uri:path url) parameters))
|
|
(gui-goodies:with-notify-errors
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(comm:make-request :titan-save-token
|
|
1
|
|
base-url
|
|
(gui:text token-entry)))
|
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
|
1
|
|
ev:+maximum-event-priority+
|
|
(to-s url)
|
|
nil
|
|
titan-data)))
|
|
(multiple-value-bind (status-code
|
|
status-description
|
|
meta
|
|
cached
|
|
original-iri)
|
|
(client-main-window::displace-gemini-response connecting-response)
|
|
(declare (ignore cached))
|
|
(cond
|
|
((or (gemini-client:header-input-p status-code)
|
|
(gemini-client:header-sensitive-input-p status-code))
|
|
(error "Server returned an invalid response ~a" status-code))
|
|
((= status-code comm:+tofu-error-status-code+)
|
|
(when (gui:ask-yesno (_ "The certificate for this address has changed, replace the old with the one I just received?")
|
|
:title (_ "Server certificate error")
|
|
:parent frame)
|
|
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
|
1
|
|
ev:+maximum-event-priority+
|
|
original-iri)
|
|
(funcall (launch-titan-request-clsr frame))))
|
|
((or (gemini-client:header-temporary-failure-p status-code)
|
|
(gemini-client:header-permanent-failure-p status-code)
|
|
(gemini-client:header-certificate-failure-p status-code))
|
|
(error "Server returned an failure response ~a ~a"
|
|
status-code
|
|
status-description))
|
|
((= status-code
|
|
comm:+certificate-password-not-found-error-status-code+)
|
|
(let* ((certificate-path meta)
|
|
(message (format nil
|
|
(_ "Provide the password to unlock certificate for ~a")
|
|
(uri:path url)))
|
|
(password (gui-goodies::password-dialog (gui:root-toplevel)
|
|
(_ "Unlock certificate")
|
|
message))
|
|
(actual-password (if (string-empty-p password)
|
|
""
|
|
password)))
|
|
(cev:enqueue-request-and-wait-results :gemini-save-certificate-key-password
|
|
1
|
|
ev:+maximum-event-priority+
|
|
certificate-path
|
|
actual-password)
|
|
(funcall (launch-titan-request-clsr frame))))
|
|
((gemini-client:header-redirect-p status-code)
|
|
(error "redirection in titan not yet implemented"))
|
|
((gemini-client:header-success-p status-code)
|
|
(gui-goodies:info-dialog frame (_ "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))))
|