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 ()
|
||||
(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))
|
||||
|
||||
(defmethod stop-stream-thread ((object gemini-stream))
|
||||
|
|
@ -1143,105 +1150,112 @@ local file paths."
|
|||
(collect-ir-lines iri main-window lines))))
|
||||
|
||||
(defun start-stream-iri (iri main-window use-cache
|
||||
&key
|
||||
(status +stream-status-streaming+)
|
||||
(process-iri-lines-function (collect-iri-lines-clsr main-window
|
||||
iri)))
|
||||
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri
|
||||
use-cache
|
||||
nil)))
|
||||
(multiple-value-bind (status-code
|
||||
status-description
|
||||
meta
|
||||
cached
|
||||
original-iri)
|
||||
(displace-gemini-response connecting-response)
|
||||
(declare (ignore original-iri cached))
|
||||
(cond
|
||||
((gemini-client:header-input-p status-code)
|
||||
(a:when-let ((actual-iri (get-user-request-query iri meta main-window)))
|
||||
(start-stream-iri actual-iri main-window nil)))
|
||||
((gemini-client:header-sensitive-input-p status-code)
|
||||
(a:when-let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
||||
(start-stream-iri actual-iri main-window nil)))
|
||||
((= 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 main-window)
|
||||
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri)
|
||||
(start-stream-iri iri main-window use-cache :status status)))
|
||||
((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))
|
||||
(let ((error-gemtext (cev:enqueue-request-and-wait-results :make-error-page
|
||||
1
|
||||
ev:+standard-event-priority+
|
||||
iri
|
||||
status-code
|
||||
status-description
|
||||
meta)))
|
||||
(render-gemtext-string main-window error-gemtext)
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(inline-all-images main-window))))
|
||||
((= 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")
|
||||
iri))
|
||||
(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)
|
||||
(start-stream-iri iri main-window use-cache :status status)))
|
||||
((gemini-client:header-redirect-p status-code)
|
||||
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
||||
:title (_ "Redirection")
|
||||
:parent main-window)
|
||||
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
||||
meta
|
||||
(absolutize-link iri meta))))
|
||||
(start-stream-iri redirect-iri main-window use-cache :status status))))
|
||||
((gemini-client:header-success-p status-code)
|
||||
(cond
|
||||
((eq status +stream-status-streaming+)
|
||||
(cond
|
||||
((gemini-client:gemini-file-stream-p meta)
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(comm:make-request :gemini-save-url-db-history 1 iri))
|
||||
(maybe-stop-streaming-stream-thread)
|
||||
(clear-gemtext main-window)
|
||||
(initialize-ir-lines main-window)
|
||||
(start-streaming-thread main-window
|
||||
iri
|
||||
:use-cache t
|
||||
:status status
|
||||
:process-function process-iri-lines-function))
|
||||
((gemini-client:text-file-stream-p meta)
|
||||
(slurp-text-data main-window iri))
|
||||
(t
|
||||
(slurp-non-text-data main-window iri))))
|
||||
((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))))))))
|
||||
&key
|
||||
(status +stream-status-streaming+)
|
||||
(process-iri-lines-function (collect-iri-lines-clsr main-window
|
||||
iri)))
|
||||
(flet ((actually-use-cache-p ()
|
||||
;; we need to use 't' or 'nil' as results from this
|
||||
;; function because the json-rpc does not know how to
|
||||
;; encode generalized booleans to JSON
|
||||
(if (url-streaming-p iri)
|
||||
t
|
||||
use-cache)))
|
||||
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri
|
||||
(actually-use-cache-p)
|
||||
nil)))
|
||||
(multiple-value-bind (status-code
|
||||
status-description
|
||||
meta
|
||||
cached
|
||||
original-iri)
|
||||
(displace-gemini-response connecting-response)
|
||||
(declare (ignore original-iri cached))
|
||||
(cond
|
||||
((gemini-client:header-input-p status-code)
|
||||
(a:when-let ((actual-iri (get-user-request-query iri meta main-window)))
|
||||
(start-stream-iri actual-iri main-window nil)))
|
||||
((gemini-client:header-sensitive-input-p status-code)
|
||||
(a:when-let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
||||
(start-stream-iri actual-iri main-window nil)))
|
||||
((= 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 main-window)
|
||||
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri)
|
||||
(start-stream-iri iri main-window use-cache :status status)))
|
||||
((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))
|
||||
(let ((error-gemtext (cev:enqueue-request-and-wait-results :make-error-page
|
||||
1
|
||||
ev:+standard-event-priority+
|
||||
iri
|
||||
status-code
|
||||
status-description
|
||||
meta)))
|
||||
(render-gemtext-string main-window error-gemtext)
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(inline-all-images main-window))))
|
||||
((= 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")
|
||||
iri))
|
||||
(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)
|
||||
(start-stream-iri iri main-window use-cache :status status)))
|
||||
((gemini-client:header-redirect-p status-code)
|
||||
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
||||
:title (_ "Redirection")
|
||||
:parent main-window)
|
||||
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
||||
meta
|
||||
(absolutize-link iri meta))))
|
||||
(start-stream-iri redirect-iri main-window use-cache :status status))))
|
||||
((gemini-client:header-success-p status-code)
|
||||
(cond
|
||||
((eq status +stream-status-streaming+)
|
||||
(cond
|
||||
((gemini-client:gemini-file-stream-p meta)
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(comm:make-request :gemini-save-url-db-history 1 iri))
|
||||
(maybe-stop-streaming-stream-thread)
|
||||
(clear-gemtext main-window)
|
||||
(initialize-ir-lines main-window)
|
||||
(start-streaming-thread main-window
|
||||
iri
|
||||
:use-cache t
|
||||
:status status
|
||||
:process-function process-iri-lines-function))
|
||||
((gemini-client:text-file-stream-p meta)
|
||||
(slurp-text-data main-window iri))
|
||||
(t
|
||||
(slurp-non-text-data main-window iri))))
|
||||
((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)
|
||||
(lambda ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue