cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- changed all recursive lock with the non-recursive type; 

- prevented opening another connection when deleting cache;

- improved rendering of html blockquote.
This commit is contained in:
cage 2023-12-02 17:17:50 +01:00
parent 8c6c69c667
commit 8f9d83fa0e
8 changed files with 69 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/api-client.lisp
View File

@ -23,7 +23,7 @@
"An istance of 'credentials' used to holds the intormation needed to
access a mastodon instance")
(defparameter *client-lock* (bt:make-recursive-lock)
(defparameter *client-lock* (bt:make-lock)
"The Lock for prevent race conditions when accessing the mastodon server")
(define-constant +credentials-filename+ "client" :test #'string=
@ -362,18 +362,18 @@ Returns nil if the user did not provided a server in the configuration file"
:folder folder)))
(program-events:push-event add-fetched-event))))
(defun-api-call update-timeline (timeline
kind
folder
&key
recover-from-skipped-statuses
local
only-media
max-id
since-id
min-id
(recover-count 0)
(limit 20))
(defun update-timeline (timeline
kind
folder
&key
recover-from-skipped-statuses
local
only-media
max-id
since-id
min-id
(recover-count 0)
(limit 20))
"Update a timeline, this function will fetch new messages and generate and event to
update the program reflectings the changes in the timeline (saves
messages in the database etc.)"
@ -385,8 +385,9 @@ Returns nil if the user did not provided a server in the configuration file"
:min-id min-id
:limit limit))
(trees (if command-line:*update-timeline-climb-message-tree*
(flatten (loop for node-status in timeline-statuses collect
(expand-status-tree node-status)))
(flatten (loop for node-status in timeline-statuses
collect
(expand-status-tree node-status)))
timeline-statuses))
(event (make-instance 'program-events:save-timeline-in-db-event
:payload trees

4
src/gemini-viewer.lisp
View File

@ -17,7 +17,7 @@
(in-package :gemini-viewer)
(defparameter *gemini-db-streams-lock* (bt:make-recursive-lock))
(defparameter *gemini-db-streams-lock* (bt:make-lock))
(define-constant +read-buffer-size+ 2048 :test #'=
:documentation "Chunk's size of the buffer when reading non gemini contents from stream")
@ -107,7 +107,7 @@
(defclass gemini-stream ()
((download-thread-lock
:initform (bt:make-recursive-lock "download-gemini")
:initform (bt:make-lock "download-gemini")
:initarg :download-thread-lock
:accessor download-thread-lock)
(download-thread-blocked

2
src/gemini/gemini-parser.lisp
View File

@ -21,7 +21,7 @@
(defparameter *list-detected* nil)
(defparameter *parser-lock* (bt:make-recursive-lock))
(defparameter *parser-lock* (bt:make-lock))
(defparameter *pre-group-id* -1)

13
src/html-utils.lisp
View File

@ -104,6 +104,8 @@
(defparameter *block-tag* nil)
(defparameter *quote-level* 0)
(defun html->text (html &key
(add-link-footnotes t) (body-footnotes-separator "")
(quote-prefix "> ") (list-item-prefix "* "))
@ -132,9 +134,7 @@ Some convenience functions are provided to works with these structures.
(when node
(cond
((stringp node)
(if *block-tag*
(princ (strcat *prefix-text-line* node) body-stream)
(princ node body-stream)))
(princ node body-stream))
((consp (car node))
(descend (car node)))
((tag= +tag-link+ node)
@ -161,6 +161,9 @@ Some convenience functions are provided to works with these structures.
(tag= +tag-div+ node))
(let ((*block-tag* t))
(format body-stream "~%")
(when *block-tag*
(loop for i from 0 below *quote-level* do
(princ *prefix-text-line* body-stream)))
(descend-children node)
(format body-stream "~%")))
((tag= +tag-list-item+ node)
@ -170,9 +173,9 @@ Some convenience functions are provided to works with these structures.
(format body-stream "~%")))
((tag= +tag-blockquote+ node)
(let ((*prefix-text-line* quote-prefix)
(*quote-level* (1+ *quote-level*))
(*block-tag* t))
(descend-children node)
(format body-stream "~%")))
(descend-children node)))
(t
(descend-children node))))))
(descend root)

30
src/misc-utils.lisp
View File

@ -991,7 +991,7 @@ to the array"
;; threads
(defmacro with-lock ((lock) &body body)
`(bt:with-recursive-lock-held (,lock)
`(bt:with-lock-held (,lock)
,@body))
(defmacro defun-w-lock (name parameters lock &body body)
@ -1003,6 +1003,34 @@ to the array"
(with-lock (,lock)
,@remaining-forms))))
(defparameter *thread-default-special-bindings* bt:*default-special-bindings*)
(definline make-thread (function &key (name nil) (initial-bindings *thread-default-special-bindings*))
(bt:make-thread function :name name :initial-bindings initial-bindings))
(definline make-lock (&optional name)
(bt:make-lock name))
(defmacro with-lock-held ((lock) &body body)
`(bt:with-lock-held (,lock)
,@body))
(definline make-condition-variable (&key (name nil))
(bt:make-condition-variable :name name))
(definline condition-wait (condition-variable lock &key (timeout nil))
(bt:condition-wait condition-variable lock :timeout timeout))
(definline condition-notify (condition-variable)
(bt:condition-notify condition-variable))
(definline join-thread (thread)
(bt:join-thread thread))
(definline destroy-thread (thread)
(bt:destroy-thread thread))
;; http
(defun get-url-content (url)

9
src/package.lisp
View File

@ -260,6 +260,15 @@
:binary-search
:defun-w-lock
:with-lock
:*thread-default-special-bindings*
:make-thread
:make-lock
:with-lock-held
:make-condition-variable
:condition-wait
:condition-notify
:join-thread
:destroy-thread
:get-url-content
:with-profile-time
:with-debug-print-profile-time

6
src/program-events.lisp
View File

@ -23,7 +23,7 @@
(define-constant +maximum-event-priority+ -2 :test #'=)
(defparameter *id-lock* (bt:make-recursive-lock))
(defparameter *id-lock* (bt:make-lock))
(defparameter *event-id* 0)
@ -100,7 +100,7 @@
(defclass events-queue (priority-queue)
((lock
:initform (bt:make-recursive-lock)
:initform (bt:make-lock)
:initarg :lock
:accessor lock)
(blocking-lock
@ -222,7 +222,7 @@
(defclass event-on-own-thread (program-event)
((lock
:initform (bt:make-recursive-lock)
:initform (bt:make-lock)
:initarg :lock
:accessor lock)
(condition-variable

2
src/ui-goodies.lisp
View File

@ -3460,7 +3460,7 @@ gemini client certificates!)."
(with-valid-yes-at-prompt (input-text y-pressed-p)
(when y-pressed-p
(with-enqueued-process ()
(db-utils:with-ready-database (:connect t)
(db-utils:with-ready-database (:connect nil)
(db:cache-delete-all)
(let ((children (remove-if (lambda (a)
(or (fs:backreference-dir-p a)