(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))))