mirror of https://codeberg.org/cage/tinmop/
- forced using the cache in 'stream-iri' if a stream for the same URL already exists.
This commit is contained in:
cage
parent
46ba8f2d07
commit
14aa2af9aa
|
|
@ -75,6 +75,13 @@
|
||||||
(defun find-streaming-stream-url ()
|
(defun find-streaming-stream-url ()
|
||||||
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
|
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
|
||||||
|
|
||||||
|
(defun url-streaming-p (url)
|
||||||
|
(find-db-stream-if (lambda (a)
|
||||||
|
(and (string= (server-stream-handle a)
|
||||||
|
url)
|
||||||
|
(eq (status a)
|
||||||
|
+stream-status-streaming+)))))
|
||||||
|
|
||||||
(defgeneric stop-stream-thread (object))
|
(defgeneric stop-stream-thread (object))
|
||||||
|
|
||||||
(defmethod stop-stream-thread ((object gemini-stream))
|
(defmethod stop-stream-thread ((object gemini-stream))
|
||||||
|
|
@ -1143,105 +1150,112 @@ local file paths."
|
||||||
(collect-ir-lines iri main-window lines))))
|
(collect-ir-lines iri main-window lines))))
|
||||||
|
|
||||||
(defun start-stream-iri (iri main-window use-cache
|
(defun start-stream-iri (iri main-window use-cache
|
||||||
&key
|
&key
|
||||||
(status +stream-status-streaming+)
|
(status +stream-status-streaming+)
|
||||||
(process-iri-lines-function (collect-iri-lines-clsr main-window
|
(process-iri-lines-function (collect-iri-lines-clsr main-window
|
||||||
iri)))
|
iri)))
|
||||||
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
(flet ((actually-use-cache-p ()
|
||||||
1
|
;; we need to use 't' or 'nil' as results from this
|
||||||
ev:+maximum-event-priority+
|
;; function because the json-rpc does not know how to
|
||||||
iri
|
;; encode generalized booleans to JSON
|
||||||
use-cache
|
(if (url-streaming-p iri)
|
||||||
nil)))
|
t
|
||||||
(multiple-value-bind (status-code
|
use-cache)))
|
||||||
status-description
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
||||||
meta
|
1
|
||||||
cached
|
ev:+maximum-event-priority+
|
||||||
original-iri)
|
iri
|
||||||
(displace-gemini-response connecting-response)
|
(actually-use-cache-p)
|
||||||
(declare (ignore original-iri cached))
|
nil)))
|
||||||
(cond
|
(multiple-value-bind (status-code
|
||||||
((gemini-client:header-input-p status-code)
|
status-description
|
||||||
(a:when-let ((actual-iri (get-user-request-query iri meta main-window)))
|
meta
|
||||||
(start-stream-iri actual-iri main-window nil)))
|
cached
|
||||||
((gemini-client:header-sensitive-input-p status-code)
|
original-iri)
|
||||||
(a:when-let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
(displace-gemini-response connecting-response)
|
||||||
(start-stream-iri actual-iri main-window nil)))
|
(declare (ignore original-iri cached))
|
||||||
((= status-code comm:+tofu-error-status-code+)
|
(cond
|
||||||
(when (gui:ask-yesno (_ "The certificate for this address has changed, replace the old with the one I just received?")
|
((gemini-client:header-input-p status-code)
|
||||||
:title (_ "Server certificate error")
|
(a:when-let ((actual-iri (get-user-request-query iri meta main-window)))
|
||||||
:parent main-window)
|
(start-stream-iri actual-iri main-window nil)))
|
||||||
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
((gemini-client:header-sensitive-input-p status-code)
|
||||||
1
|
(a:when-let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
||||||
ev:+maximum-event-priority+
|
(start-stream-iri actual-iri main-window nil)))
|
||||||
iri)
|
((= status-code comm:+tofu-error-status-code+)
|
||||||
(start-stream-iri iri main-window use-cache :status status)))
|
(when (gui:ask-yesno (_ "The certificate for this address has changed, replace the old with the one I just received?")
|
||||||
((or (gemini-client:header-temporary-failure-p status-code)
|
:title (_ "Server certificate error")
|
||||||
(gemini-client:header-permanent-failure-p status-code)
|
:parent main-window)
|
||||||
(gemini-client:header-certificate-failure-p status-code))
|
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
||||||
(let ((error-gemtext (cev:enqueue-request-and-wait-results :make-error-page
|
1
|
||||||
1
|
ev:+maximum-event-priority+
|
||||||
ev:+standard-event-priority+
|
iri)
|
||||||
iri
|
(start-stream-iri iri main-window use-cache :status status)))
|
||||||
status-code
|
((or (gemini-client:header-temporary-failure-p status-code)
|
||||||
status-description
|
(gemini-client:header-permanent-failure-p status-code)
|
||||||
meta)))
|
(gemini-client:header-certificate-failure-p status-code))
|
||||||
(render-gemtext-string main-window error-gemtext)
|
(let ((error-gemtext (cev:enqueue-request-and-wait-results :make-error-page
|
||||||
(ev:with-enqueued-process-and-unblock ()
|
1
|
||||||
(inline-all-images main-window))))
|
ev:+standard-event-priority+
|
||||||
((= status-code
|
iri
|
||||||
comm:+certificate-password-not-found-error-status-code+)
|
status-code
|
||||||
(let* ((certificate-path meta)
|
status-description
|
||||||
(message (format nil
|
meta)))
|
||||||
(_ "Provide the password to unlock certificate for ~a")
|
(render-gemtext-string main-window error-gemtext)
|
||||||
iri))
|
(ev:with-enqueued-process-and-unblock ()
|
||||||
(password (gui-goodies::password-dialog (gui:root-toplevel)
|
(inline-all-images main-window))))
|
||||||
(_ "Unlock certificate")
|
((= status-code
|
||||||
message))
|
comm:+certificate-password-not-found-error-status-code+)
|
||||||
(actual-password (if (string-empty-p password)
|
(let* ((certificate-path meta)
|
||||||
""
|
(message (format nil
|
||||||
password)))
|
(_ "Provide the password to unlock certificate for ~a")
|
||||||
(cev:enqueue-request-and-wait-results :gemini-save-certificate-key-password
|
iri))
|
||||||
1
|
(password (gui-goodies::password-dialog (gui:root-toplevel)
|
||||||
ev:+maximum-event-priority+
|
(_ "Unlock certificate")
|
||||||
certificate-path
|
message))
|
||||||
actual-password)
|
(actual-password (if (string-empty-p password)
|
||||||
(start-stream-iri iri main-window use-cache :status status)))
|
""
|
||||||
((gemini-client:header-redirect-p status-code)
|
password)))
|
||||||
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
(cev:enqueue-request-and-wait-results :gemini-save-certificate-key-password
|
||||||
:title (_ "Redirection")
|
1
|
||||||
:parent main-window)
|
ev:+maximum-event-priority+
|
||||||
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
certificate-path
|
||||||
meta
|
actual-password)
|
||||||
(absolutize-link iri meta))))
|
(start-stream-iri iri main-window use-cache :status status)))
|
||||||
(start-stream-iri redirect-iri main-window use-cache :status status))))
|
((gemini-client:header-redirect-p status-code)
|
||||||
((gemini-client:header-success-p status-code)
|
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
||||||
(cond
|
:title (_ "Redirection")
|
||||||
((eq status +stream-status-streaming+)
|
:parent main-window)
|
||||||
(cond
|
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
||||||
((gemini-client:gemini-file-stream-p meta)
|
meta
|
||||||
(ev:with-enqueued-process-and-unblock ()
|
(absolutize-link iri meta))))
|
||||||
(comm:make-request :gemini-save-url-db-history 1 iri))
|
(start-stream-iri redirect-iri main-window use-cache :status status))))
|
||||||
(maybe-stop-streaming-stream-thread)
|
((gemini-client:header-success-p status-code)
|
||||||
(clear-gemtext main-window)
|
(cond
|
||||||
(initialize-ir-lines main-window)
|
((eq status +stream-status-streaming+)
|
||||||
(start-streaming-thread main-window
|
(cond
|
||||||
iri
|
((gemini-client:gemini-file-stream-p meta)
|
||||||
:use-cache t
|
(ev:with-enqueued-process-and-unblock ()
|
||||||
:status status
|
(comm:make-request :gemini-save-url-db-history 1 iri))
|
||||||
:process-function process-iri-lines-function))
|
(maybe-stop-streaming-stream-thread)
|
||||||
((gemini-client:text-file-stream-p meta)
|
(clear-gemtext main-window)
|
||||||
(slurp-text-data main-window iri))
|
(initialize-ir-lines main-window)
|
||||||
(t
|
(start-streaming-thread main-window
|
||||||
(slurp-non-text-data main-window iri))))
|
iri
|
||||||
((eq status +stream-status-downloading+)
|
:use-cache t
|
||||||
(when (not (find-db-stream-url iri))
|
:status status
|
||||||
(let ((background-stream (make-instance 'gemini-stream
|
:process-function process-iri-lines-function))
|
||||||
:server-stream-handle iri
|
((gemini-client:text-file-stream-p meta)
|
||||||
:status status)))
|
(slurp-text-data main-window iri))
|
||||||
(push-db-stream background-stream))))
|
(t
|
||||||
(t
|
(slurp-non-text-data main-window iri))))
|
||||||
(error "Unrecognized stream status for address ~s: ~s" iri status))))))))
|
((eq status +stream-status-downloading+)
|
||||||
|
(when (not (find-db-stream-url iri))
|
||||||
|
(let ((background-stream (make-instance 'gemini-stream
|
||||||
|
:server-stream-handle iri
|
||||||
|
:status status)))
|
||||||
|
(push-db-stream background-stream))))
|
||||||
|
(t
|
||||||
|
(error "Unrecognized stream status for address ~s: ~s" iri status)))))))))
|
||||||
|
|
||||||
(defun open-iri-clsr (main-window use-cache)
|
(defun open-iri-clsr (main-window use-cache)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue