- added purging of unused mentions from database;

- fixed function to clean configuration directives relate dto purging entries from database (history, mentions etc.).

.gitignore

@@ -32,4 +32,6 @@ src/config.lisp.in
 *.patch
 *.log
 
+make-debian.sh
+
 tinmop

ChangeLog

@@ -1,8 +1,527 @@
+2024-09-27 cage
+
+	* src/db.lisp,
+	* src/gui/server/json-rpc-communication.lisp,
+	* src/text-utils.lisp:
+
+	- [GUI] ensured cleaning of temporary files on exit.
+	- [fediverse] ensured the posts do not contains non printable
+	characters.
+
+2024-09-26 cage
+
+	* README.org,
+	* quick_quicklisp.sh.in,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/program-events.lisp,
+	* src/gui/client/stream-frame.lisp:
+
+	- [GUI] moved refreshing stream table before starting streaming, to
+	prevent a race condition.
+	- [GUI] added comment about race condition;
+	- [GUI] added name to each thread spawned.
+	- [GUI] updated comment about the race condition;
+	- [GUI] try to open a non gemini file even if the mininum buffer size
+	has not be reached, but the file has been downloaded entirely.
+	- changed croatoan repository url.
+
+2024-09-25 cage
+
+	* src/gui/client/main-window.lisp,
+	* src/ui-goodies.lisp:
+
+	- [GUI] used 'open-iri' to open the redirection iri.
+	- [fediverse] used quoted lines in reply's text.
+
+2024-09-24 cage
+
+	* src/db.lisp,
+	* src/message-rendering-utils.lisp,
+	* src/package.lisp,
+	* src/program-events.lisp,
+	* src/ui-goodies.lisp:
+
+	- [fediverse] removed spurious text added when editing a post;
+	- [fediverse] fixed mention expanding.
+
+2024-09-23 cage
+
+	* src/gui/client/main-window.lisp,
+	* src/ui-goodies.lisp:
+
+	- [GUI] fixed redirection.
+	- [fediverse] fixed regression: missing quoted text when replying to a
+	messages without any mention.
+
+2024-09-22 cage
+
+	* src/db.lisp,
+	* src/gempub.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/html-utils.lisp,
+	* src/message-rendering-utils.lisp,
+	* src/package.lisp,
+	* src/ui-goodies.lisp:
+
+	- [GUI] fixed regression, opening non gemini absolute IRI was not
+	possible.
+	- fixed parsing of gempub metadata.
+	- [fediverse] reworked mention in messages.
+
+2024-09-21 cage
+
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/api-client.lisp,
+	* src/command-line.lisp,
+	* src/command-window.lisp,
+	* src/conversations-window.lisp,
+	* src/db.lisp,
+	* src/follow-requests.lisp,
+	* src/gemini-viewer.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/stream-frame.lisp,
+	* src/gui/server/main-window-server-side.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/keybindings.lisp,
+	* src/text-utils.lisp,
+	* src/ui-goodies.lisp:
+
+	- [gui] disabled gempub menu if there is no support for zip files
+	(zip/unzip executables not found);
+	- [gui] added to history also local paths.
+	- [GUI] updated address bar when opening a directory and then a file.
+	- fixed typos using codespell.
+	- updated italian translation.
+	Merge pull request 'Translations update from Codeberg Translate' (#20)
+	from translate/tinmop:weblate-tinmop-tinmop into master
+	Translated using Weblate (Italian)
+	Currently translated at 100.0% (596 of 596 strings)
+	Translation: tinmop/tinmop
+	Translate-URL:
+	https://translate.codeberg.org/projects/tinmop/tinmop/it/
+	Merge pull request 'Translations update from Codeberg Translate' (#21)
+	from translate/tinmop:weblate-tinmop-tinmop into master
+	- [gui] prevented creating a new file with editor
+	when a string not representing an absolute IRI, or an existing path in
+	a local file system was  typed on the address bar, the program tried
+	to open it with an external program (example, starting an editor)
+	instead of trigger a search on the gemspace.
+
+2024-09-20 cage
+
+	* src/gui/client/gempub-window.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/menu-command.lisp,
+	* src/package.lisp:
+
+	- [GUI] added command to import a gempub file.
+	- [GUI] bound 'delete' key to a routine that delete a gempub.
+
+2024-09-18 cage
+
+	* Makefile.in,
+	* aclocal.m4,
+	* configure,
+	* configure.ac,
+	* src/config.lisp.in.in,
+	* src/gempub.lisp,
+	* src/gui/client/certificates-window.lisp,
+	* src/gui/client/gemlog-window.lisp,
+	* src/gui/client/gempub-window.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/menu-command.lisp,
+	* src/misc-utils.lisp,
+	* src/os-utils.lisp,
+	* src/package.lisp:
+
+	- [GUI] added UI to generate a gempub;
+	- fixed parser for gempub metadata;
+	- fixed typo: "clrs" instead of "clsr";
+	- added dependency to "zip" binary.
+	- used 'gpub' as file extension for generated gempub files.
+
+2024-09-15 cage
+
+	* Makefile.am,
+	* Makefile.in,
+	* data/cover.gmi,
+	* src/db.lisp,
+	* src/filesystem-utils.lisp,
+	* src/gui/client/gempub-window.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/scheduler.lisp,
+	* src/gui/server/public-api-gemini-gempub.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/package.lisp:
+
+	- added missing files for gempub managements.
+	- added 'db:gempub-metadata-id->path';
+	- used local nickname instead of importing alexandria for package
+	'db'.
+	- fixed 'fs:temporary-directory'.
+	- added basic gempub rendering routines.
+	- [GUI] changed test for checking a local file;
+	- [GUI] checked, when a image is inlined, if it comes from a local
+	path, then try to figure out the format from the file's extension;
+	- [GUI] [gempub] fixed inlining of cover file.
+	- [GUI] [gempub] forced inlining of cover image.
+
+2024-09-14 cage
+
+	* doc/tinmop.org,
+	* etc/shared-gui.conf,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/menu-command.lisp,
+	* src/gui/client/scheduler.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/package.lisp,
+	* src/zip-info.lisp,
+	* tinmop.asd:
+
+	- [GUI] added initial support for gempub;
+	- [DOC] fixed syntax of query language for searching in gempub
+	library.
+
+2024-09-08 cage
+
+	* src/api-client.lisp:
+
+	- [fediverse] flipped predicate for notifications that does not need
+	to be deleted from the server.
+
+2024-09-07 cage
+
+	* src/api-client.lisp:
+
+	- [fediverse] ensured :follow-request and :mentions are kept on the
+	server when deleting noticfications.
+
+2024-09-06 cage
+
+	* data/modules/fetch-expired-poll.lisp,
+	* etc/default-theme.conf,
+	* src/api-client.lisp,
+	* src/gempub.lisp,
+	* src/hooks.lisp,
+	* src/package.lisp:
+
+	- fixed rule's name, this bug leads to a crash when extracting
+	metadata from a gempub file.
+	- fixed indentation.
+	- [TUI] dimmed a bit the blue in the default theme and used white
+	instead of yellow in a few window, also changed colors for dialog
+	window.
+	- dimmed some theme's colors.
+	- [TUI] changed colors for default theme.
+	- [TUI] changed some values of default theme.
+	- added 'hooks:*after-getting-all-fediverse-notifications*';
+	- trigger the script to fetch expired polls only after all the
+	notifications has been fetched from the server.
+
+2024-09-04 cage
+
+	* src/gemini/client.lisp,
+	* src/gui/client/gemlog-window.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/json-rpc2.lisp,
+	* src/package.lisp:
+
+	- [GUI] ensured deadline conditions is respected by gemlog subscribing
+	procedures.
+	- [gemini] using asynchronous timeout instead when opening a socket as
+	the function to open a socket does not respect deadline established
+	with 'sb-sys:with-deadline'.
+
+2024-09-03 cage
+
+	* etc/shared.conf,
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/ui-goodies.lisp:
+
+	- [fediverse] added a commented line on top when composing a new post;
+	- updated italian translation.
+	- [fediverse] added comment line character when composing posts.
+
+2024-09-01 Omar Polo, cage
+
+	* ChangeLog,
+	* LICENSES.org,
+	* NEWS.org,
+	* README.org,
+	* doc/tinmop.man,
+	* doc/tinmop.org,
+	* etc/default-theme.conf,
+	* etc/init.lisp,
+	* etc/shared.conf,
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* quick_quicklisp.sh.in,
+	* src/api-client.lisp,
+	* src/command-line.lisp,
+	* src/command-window.lisp,
+	* src/complete.lisp,
+	* src/conditions.lisp,
+	* src/constants.lisp,
+	* src/db-utils.lisp,
+	* src/db.lisp,
+	* src/emoji-shortcodes.lisp,
+	* src/filesystem-tree-window.lisp,
+	* src/filesystem-utils.lisp,
+	* src/gemini-viewer.lisp,
+	* src/gemini/client.lisp,
+	* src/gemini/titan.lisp,
+	* src/gui/client/gui-goodies.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/stream-frame.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/idn.lisp,
+	* src/iri-parser.lisp,
+	* src/json-rpc2.lisp,
+	* src/kami/client.lisp,
+	* src/keybindings.lisp,
+	* src/line-oriented-window.lisp,
+	* src/message-rendering-utils.lisp,
+	* src/message-window.lisp,
+	* src/misc-utils.lisp,
+	* src/num-utils.lisp,
+	* src/open-attach-window.lisp,
+	* src/package.lisp,
+	* src/program-events.lisp,
+	* src/resources-utils.lisp,
+	* src/software-configuration.lisp,
+	* src/ui-goodies.lisp,
+	* src/windows.lisp:
+
+	fix typos; joint work with codespell(1)
+	Merge pull request 'fix typos; joint work with codespell(1)' (#19)
+	from op/tinmop:typos into master
+	- added comments when composing posts.
+	- fixed typo: 'octect' to 'octet';
+	- removed fuzzy mark from italian transtation file.
+	- fixed code formatting.
+	- deprecated "crypted" as valid configuration directive.
+
+2024-08-31 cage
+
+	* LICENSES.org,
+	* data/emoji-shortcodes.json,
+	* etc/default-theme.conf,
+	* etc/shared.conf,
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/emoji-shortcodes.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/main.lisp,
+	* src/package.lisp,
+	* src/software-configuration.lisp,
+	* src/ui-goodies.lisp:
+
+	- [TUI] added conversion of shortcodes to emoji when composing a
+	fediverse post.
+	- removed debugging code.
+	- deprecated configuration directive 'post-allowed-language';
+	- added configuration directive for comments in composed posts.
+	- deleted unreachable code (links are rendered without the help of
+	'key->colors', see 'render-link' on the same file).
+
+2024-08-30 cage
+
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/gui/client/gemlog-window.lisp,
+	* src/gui/client/main-window.lisp:
+
+	- [GUI] added a button to popup menu to subscribe to a gemlog link.
+	- [GUI] refresh gemlog window when marking posts as already read.
+	- updated italian translation.
+
+2024-08-26 cage
+
+	* src/command-line.lisp,
+	* src/package.lisp:
+
+	- added code to allow scripts to gets their command line switches
+	those switches (if any) after the "--" are returned by function
+	"script-arguments"
+	and can be used by scripts.
+
+2024-08-25 cage
+
+	* src/command-line.lisp,
+	* src/gui/client/gemlog-window.lisp,
+	* src/gui/server/public-api-gemini-gemlog.lisp:
+
+	- [GUI] added button to subscribe to a gemlog from gemlog window.
+	- [GUI] notify to user any conditions (to include deadlines) when
+	refreshing gemlogs.
+	- cleaned up bash completion procedures.
+
+2024-08-24 cage
+
+	* LICENSES.org,
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/gemini-viewer.lisp,
+	* src/gemini/client.lisp,
+	* src/gemini/package.lisp,
+	* src/gemini/subscription.lisp,
+	* src/gemini/titan.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/titan-window.lisp,
+	* src/gui/server/public-api-gemini-gemlog.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/package.lisp,
+	* src/x509.lisp:
+
+	- [gemini] added a notice when connecting with an host that provided
+	an expired certificate;
+	- added more information on license file.
+	- updated italian translation.
+
+2024-08-10 cage
+
+	* etc/default-theme.conf,
+	* src/keybindings.lisp,
+	* src/line-oriented-window.lisp,
+	* src/ui-goodies.lisp:
+
+	- [TUI] ensured the help window uses 'help-dialog' configuration
+	directives;
+	- [TUI] changed default color for info windows.
+
+2024-08-04 cage
+
+	* po/ca.po,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/api-client.lisp,
+	* src/gui/client/gemlog-window.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/software-configuration.lisp:
+
+	- [GUI] added index column to gemlog window.
+	- updated italian translation.
+	- [GUI] prevented stack overflow (ensured TCO) when downloading a non
+	gemini text file.
+	- removed possible infinite loop when getting many notification (the
+	exact number depends from from the server configuration, usually more
+	then 15 notifications would remove the exit condition of the loop).
+	Thanks to the fediverse! :-)
+
+2024-08-02 cage
+
+	* etc/shared-gui.conf,
+	* src/gemini/gemini-parser.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/iri-parser.lisp,
+	* src/package.lisp:
+
+	- [GUI] fixed URI printed on address bar when opening an URI from the
+	command line (switch '-o');
+	- [GUI] changed selection colors in gemtext widget.
+	- fixed 'iri:absolute-url-p';
+	- fixed 'gemini-parser:absolutize-link'.
+
+2024-08-01 cage
+
+	* src/gui/client/main-window.lisp:
+
+	- [GUI] ensure the default text for the gemini text widget respects
+	the directive 'text color' in the configuration file for simple text
+	line type.
+
+2024-07-31 cage
+
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/program-events.lisp,
+	* src/program-events.lisp:
+
+	- added nested expansion of 'with-enqueued-process-and-unblock' and
+	'enqueue-request-and-wait-results'.
+
+2024-07-27 cage
+
+	* src/gui/client/main-window.lisp,
+	* src/program-events.lisp:
+
+	- [GUI] fixed crash when zooming or unzooming a gemtext window with
+	inlined images.
+	- [GUI] removed bindings to return to a previously visited page (maybe
+	added for testing?).
+
+2024-07-20 cage
+
+	* etc/shared-gui.conf,
+	* src/program-events.lisp:
+
+	- modified default GUI theme.
+	- prevented to replace a post's content with an empty text.
+
+2024-07-11 cage
+
+	* doc/tinmop.man,
+	* doc/tinmop.org:
+
+	- updated docs.
+
+2024-07-10 cage
+
+	* src/db.lisp,
+	* src/package.lisp,
+	* src/program-events.lisp:
+
+	- ensured no reconstruction of parents id done when deleting a status
+	after remote editing;
+	- removed status to ensure get the latest version from the server when
+	updating a timeline or expanding a thread (and forcing ignoring of
+	logical deleted posts).
+
 2024-07-07 cage
 
+	* ChangeLog,
+	* NEWS.org,
 	* po/it.po:
 
 	- removed fuzzy bit otherwise MO file will not contains such entry.
+	- updated news and changelog.
 
 2024-07-06 cage
 

NEWS.org

@@ -1,3 +1,12 @@
+* 2024-09-27 version 0.9.9.141421356237
+  - New features
+    - [GUI] added support for gempub files
+      https://codeberg.org/oppenlab/gempub/src/branch/main
+  - Improvements
+  - Bugfix
+    - fediverse mentions in a post should work as intended;
+    - many, many bugs fixed, see the changelog file for details.
+
 * 2024-07-07 version 0.9.9.14142135623
   - New features
     - [fediverse] added command to search on local database of posts;

README.org

@@ -165,7 +165,7 @@ Note that, at the moment, the ~quick_quicklisp.sh~ script will *not* install the
 
      #+BEGIN_SRC sh
      $ cd $HOME/quicklisp/local-projects/
-     $ git clone https://github.com/McParen/croatoan.git
+     $ git clone https://codeberg.org/McParen/croatoan.git
      #+END_SRC
 
   5. build the executable:

configure

@@ -1,6 +1,6 @@
 #! /bin/sh
 # Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.72 for tinmop 0.9.9.14142135623.
+# Generated by GNU Autoconf 2.72 for tinmop 0.9.9.141421356237.
 #
 # Report bugs to <https://codeberg.org/cage/tinmop/>.
 #
@@ -604,8 +604,8 @@ MAKEFLAGS=
 # Identity of this package.
 PACKAGE_NAME='tinmop'
 PACKAGE_TARNAME='tinmop'
-PACKAGE_VERSION='0.9.9.14142135623'
-PACKAGE_STRING='tinmop 0.9.9.14142135623'
+PACKAGE_VERSION='0.9.9.141421356237'
+PACKAGE_STRING='tinmop 0.9.9.141421356237'
 PACKAGE_BUGREPORT='https://codeberg.org/cage/tinmop/'
 PACKAGE_URL='https://www.autistici.org/interzona/tinmop.html'
 
@@ -1347,7 +1347,7 @@ if test "$ac_init_help" = "long"; then
   # Omit some internal or obsolete options to make the list less imposing.
   # This message is too long to be a string in the A/UX 3.1 sh.
   cat <<_ACEOF
-'configure' configures tinmop 0.9.9.14142135623 to adapt to many kinds of systems.
+'configure' configures tinmop 0.9.9.141421356237 to adapt to many kinds of systems.
 
 Usage: $0 [OPTION]... [VAR=VALUE]...
 
@@ -1418,7 +1418,7 @@ fi
 
 if test -n "$ac_init_help"; then
   case $ac_init_help in
-     short | recursive ) echo "Configuration of tinmop 0.9.9.14142135623:";;
+     short | recursive ) echo "Configuration of tinmop 0.9.9.141421356237:";;
    esac
   cat <<\_ACEOF
 
@@ -1523,7 +1523,7 @@ fi
 test -n "$ac_init_help" && exit $ac_status
 if $ac_init_version; then
   cat <<\_ACEOF
-tinmop configure 0.9.9.14142135623
+tinmop configure 0.9.9.141421356237
 generated by GNU Autoconf 2.72
 
 Copyright (C) 2023 Free Software Foundation, Inc.
@@ -1766,7 +1766,7 @@ cat >config.log <<_ACEOF
 This file contains any messages produced by compilers while
 running configure, to aid debugging if configure makes a mistake.
 
-It was created by tinmop $as_me 0.9.9.14142135623, which was
+It was created by tinmop $as_me 0.9.9.141421356237, which was
 generated by GNU Autoconf 2.72.  Invocation command line was
 
   $ $0$ac_configure_args_raw
@@ -3060,7 +3060,7 @@ fi
 
 # Define the identity of the package.
  PACKAGE='tinmop'
- VERSION='0.9.9.14142135623'
+ VERSION='0.9.9.141421356237'
 
 
 printf "%s\n" "#define PACKAGE \"$PACKAGE\"" >>confdefs.h
@@ -8923,7 +8923,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
 # report actual input values of CONFIG_FILES etc. instead of their
 # values after options handling.
 ac_log="
-This file was extended by tinmop $as_me 0.9.9.14142135623, which was
+This file was extended by tinmop $as_me 0.9.9.141421356237, which was
 generated by GNU Autoconf 2.72.  Invocation command line was
 
   CONFIG_FILES    = $CONFIG_FILES
@@ -8983,7 +8983,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\
 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
 ac_cs_config='$ac_cs_config_escaped'
 ac_cs_version="\\
-tinmop config.status 0.9.9.14142135623
+tinmop config.status 0.9.9.141421356237
 configured by $0, generated by GNU Autoconf 2.72,
   with options \\"\$ac_cs_config\\"
 

configure.ac

@@ -15,7 +15,7 @@ dnl You should have received a copy of the GNU General Public License
 dnl along with this program.
 dnl If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
 
-AC_INIT([tinmop],[0.9.9.14142135623],[https://codeberg.org/cage/tinmop/],[tinmop],[https://www.autistici.org/interzona/tinmop.html])
+AC_INIT([tinmop],[0.9.9.141421356237],[https://codeberg.org/cage/tinmop/],[tinmop],[https://www.autistici.org/interzona/tinmop.html])
 
 AM_INIT_AUTOMAKE([-Wall foreign])
 

etc/shared.conf

@@ -29,10 +29,16 @@ reply-quoted-character                      = "> "
 
 # delete the command  history entries that are older  than this number
 # of days
-purge-history-days-offset                   = -30
+purge-history-days-offset                   =  30
 
 # delete the cache entries that are older than this number of days
-purge-cache-days-offset                     = -7
+purge-cache-days-offset                     =  7
+
+# delete the cache entries that are older than this number of days
+purge-gemlog-seen-post-days-offset          =  255
+
+# delete the mentions from database that has not been used after this number of days
+purge-post-mention-days-offset              = 200
 
 # chosen editor (as shell command line) for compose a message
 editor                                      = "nano --locking"

quick_quicklisp.sh.in

@@ -35,7 +35,7 @@ LISP_SOURCE_REGISTRY_FILE="$LISP_SOURCE_REGISTRY_DIR/source-registry.conf"
 
 VERIFY_OK_RES=2
 
-CROATOAN_GIT_URL=https://github.com/McParen/croatoan.git
+CROATOAN_GIT_URL=https://codeberg.org/McParen/croatoan.git
 
 CROATOAN_DIR="$QUICKLISP_INSTALL_DIR"/local-projects/croatoan/
 

src/db.lisp

@@ -80,6 +80,9 @@
 (a:define-constant +table-account+                :account
   :test #'eq)
 
+(a:define-constant +table-mention+                :mention
+  :test #'eq)
+
 (a:define-constant +table-poll-option+            :poll-option
   :test #'eq)
 
@@ -408,6 +411,18 @@
                            " UNIQUE(id) ON CONFLICT FAIL"
                            +make-close+)))
 
+(defun make-mention ()
+  (query-low-level (strcat (prepare-table +table-mention+)
+                           " username              TEXT    NOT NULL,"
+                           ;; this is the actual user identification
+                           " acct                  TEXT    NOT NULL,"
+                           ;; profile homepage
+                           " url                   TEXT    NOT NULL,"
+                           ;; local value, timestamp
+                           " \"date-added\"        TEXT NOT NULL,"
+                           " UNIQUE(id) ON CONFLICT FAIL"
+                           +make-close+)))
+
 (defun make-followed-user ()
   (query-low-level (strcat (prepare-table +table-followed-user+ :integer-id-p t :autoincrementp t)
                            " \"user-id\" TEXT "
@@ -429,7 +444,7 @@
 (defun make-poll ()
   (query-low-level (strcat (prepare-table +table-poll+ :autogenerated-id-p t)
                            " \"status-id\" TEXT NOT NULL "
-                                        ;(make-foreign +table-status+ "status-id" +cascade+ +cascade+)
+                           ;;(make-foreign +table-status+ "status-id" +cascade+ +cascade+)
                            +col-sep+
                            ;; date
                            " \"expire-date\"  TEXT    NOT NULL,"
@@ -679,6 +694,7 @@
               +table-input-history+
               +table-status+
               +table-account+
+              +table-mention+
               +table-followed-user+
               +table-subscribed-tag+
               +table-tag-histogram+
@@ -716,6 +732,7 @@
     (make-input-history)
     (make-crypto-data)
     (make-account)
+    (make-mention)
     (make-followed-user)
     (make-status)
     (make-ignored-status)
@@ -907,14 +924,21 @@ than `max-id'"
   (local-time:adjust-timestamp (local-time-obj-now)
     (offset :day (- (abs days-in-the-past)))))
 
+(defun purge-by-date-added (table threshold)
+    "Remove expired entry in history.
+An entry is expired if older than `threshold' days in the past"
+    (query (make-delete table
+               (:< :date-added (prepare-for-db threshold)))))
+
 (defun purge-history ()
   "Remove expired entry in history.
 
 An         entry          is         expired          if         older
 than (swconf:config-purge-history-days-offset) days in the past"
-  (let ((threshold (threshold-time (swconf:config-purge-history-days-offset))))
-    (query (make-delete +table-input-history+
-               (:< :date-added (prepare-for-db threshold))))))
+  (purge-by-date-added +table-input-history+ (swconf:config-purge-history-days-offset)))
+
+(defun purge-post-mentions ()
+  (purge-by-date-added +table-mention+ (swconf:config-purge-post-mention-days-offset)))
 
 (defun history-prompt->values (prompt)
   (mapcar #'second
@@ -1200,6 +1224,9 @@ than (swconf:config-purge-history-days-offset) days in the past"
            (query ,update-query)
            (query ,insert-query)))))
 
+(defun clean-chars (text)
+  (clean-unprintable-chars (remove-corrupting-utf8-chars text)))
+
 (defmethod update-db ((object tooter:account) &key &allow-other-keys)
   (with-accessors ((id               tooter:id)
                    (username         tooter:username)
@@ -1219,55 +1246,53 @@ than (swconf:config-purge-history-days-offset) days in the past"
                    (statuses-count   tooter:statuses-count)
                    (moved            tooter:moved)
                    (bot              tooter:bot)) object
-    (flet ((clean-chars (string)
-             (remove-corrupting-utf8-chars string)))
-      (let ((actual-created-at   (decode-datetime-string created-at))
-            (actual-botp         (prepare-for-db bot          :to-integer t))
-            (actual-username     (clean-chars username))
-            (actual-display-name (clean-chars display-name))
-            (actual-discoverable (prepare-for-db discoverable :to-integer t))
-            (actual-locked       (prepare-for-db locked       :to-integer t))
-            (actual-moved-id     (if moved
-                                     (prepare-for-db (tooter:id moved))
-                                     (prepare-for-db nil))))
-        (complete:initialize-complete-username-cache)
-        (insert-or-update +table-account+
-                          (:id
-                           :username
-                           :acct
-                           :url
-                           :display-name
-                           :note
-                           :avatar
-                           :avatar-static
-                           :header
-                           :header-static
-                           :locked
-                           :discoverable
-                           :created-at
-                           :followers-count
-                           :following-count
-                           :statuses-count
-                           :moved-id
-                           :botp)
-                          (id
-                           actual-username
-                           account-name
-                           url
-                           actual-display-name
-                           note
-                           avatar
-                           avatar-static
-                           header
-                           header-static
-                           actual-locked
-                           actual-discoverable
-                           actual-created-at
-                           followers-count
-                           following-count
-                           statuses-count
-                           actual-moved-id
-                           actual-botp))))))
+    (let ((actual-created-at   (decode-datetime-string created-at))
+          (actual-botp         (prepare-for-db bot          :to-integer t))
+          (actual-username     (clean-chars username))
+          (actual-display-name (clean-chars display-name))
+          (actual-discoverable (prepare-for-db discoverable :to-integer t))
+          (actual-locked       (prepare-for-db locked       :to-integer t))
+          (actual-moved-id     (if moved
+                                   (prepare-for-db (tooter:id moved))
+                                   (prepare-for-db nil))))
+      (complete:initialize-complete-username-cache)
+      (insert-or-update +table-account+
+                        (:id
+                         :username
+                         :acct
+                         :url
+                         :display-name
+                         :note
+                         :avatar
+                         :avatar-static
+                         :header
+                         :header-static
+                         :locked
+                         :discoverable
+                         :created-at
+                         :followers-count
+                         :following-count
+                         :statuses-count
+                         :moved-id
+                         :botp)
+                        (id
+                         actual-username
+                         account-name
+                         url
+                         actual-display-name
+                         note
+                         avatar
+                         avatar-static
+                         header
+                         header-static
+                         actual-locked
+                         actual-discoverable
+                         actual-created-at
+                         followers-count
+                         following-count
+                         statuses-count
+                         actual-moved-id
+                         actual-botp)))))
 
 (defmethod update-db ((object tooter:tag-history) &key (tag nil) &allow-other-keys)
   (assert (stringp tag))
@@ -1302,6 +1327,26 @@ than (swconf:config-purge-history-days-offset) days in the past"
                            +tag-separator+)
         "")))
 
+(defmethod update-db ((object tooter:mention) &key &allow-other-keys)
+  (with-accessors ((id               tooter:id)
+                   (username         tooter:username)
+                   (account-name     tooter:account-name)
+                   (url              tooter:url)) object
+    (let ((actual-username (clean-chars username))
+          (actual-acct     (clean-chars account-name))
+          (now             (prepare-for-db (local-time-obj-now))))
+      (insert-or-update +table-mention+
+                        (:id
+                         :username
+                         :acct
+                         :url
+                         :date-added)
+                        (id
+                         actual-username
+                         actual-acct
+                         url
+                         now)))))
+
 (defmethod update-db ((object tooter:status)
                       &key
                         (timeline +local-timeline+)
@@ -1330,30 +1375,33 @@ than (swconf:config-purge-history-days-offset) days in the past"
                    (tags                   tooter:tags)
                    (application            tooter:application)
                    (media-attachments      tooter:media-attachments)
-                   (poll                   tooter:poll)) object
+                   (poll                   tooter:poll)
+                   (mentions               tooter:mentions)) object
     (update-db account)
-    (let* ((account-id         (tooter:id account))
-           (actual-created-at  (decode-datetime-string created-at))
-           (actual-application (prepare-for-db application))
-           (tag-names          (if tags
-                                   (mapcar #'client:tag-name tags)
-                                   '()))
-           (actual-tags        (concat-tags object))
-           (actual-language    (prepare-for-db language))
+    (mapcar #'update-db mentions)
+    (let* ((account-id          (tooter:id account))
+           (actual-created-at   (decode-datetime-string created-at))
+           (actual-application  (prepare-for-db application))
+           (tag-names           (if tags
+                                    (mapcar #'client:tag-name tags)
+                                    '()))
+           (actual-tags         (concat-tags object))
+           (actual-language     (prepare-for-db language))
            ;; use string-downcase as a workaround because tooter return an upcased keyword
-           (actual-visibility  (string-downcase (prepare-for-db visibility)))
-           (actual-sensitive   (prepare-for-db sensitive  :to-integer t))
-           (actual-favourited  (prepare-for-db favourited :to-integer t))
-           (actual-pinned      (prepare-for-db pinned     :to-integer t))
-           (actual-reblogged   (prepare-for-db reblogged  :to-integer t))
-           (actual-muted       (prepare-for-db muted      :to-integer t))
-           (rendered-text      (msg-utils:message-original->text-body content
-                                                                      :try-decrypt nil))
-           (reblog-id          (if parent
-                                   (prepare-for-db (tooter:id parent))
-                                   (prepare-for-db nil)))
-           (account-ignored-p  (user-ignored-p account-id))
-           (status-ignored-p   (status-ignored-p id folder timeline)))
+           (actual-visibility   (string-downcase (prepare-for-db visibility)))
+           (actual-sensitive    (prepare-for-db sensitive  :to-integer t))
+           (actual-favourited   (prepare-for-db favourited :to-integer t))
+           (actual-pinned       (prepare-for-db pinned     :to-integer t))
+           (actual-reblogged    (prepare-for-db reblogged  :to-integer t))
+           (actual-muted        (prepare-for-db muted      :to-integer t))
+           (actual-spoiler-text (clean-chars spoiler-text))
+           (rendered-text       (msg-utils:message-original->text-body content
+                                                                       :try-decrypt nil))
+           (reblog-id           (if parent
+                                    (prepare-for-db (tooter:id parent))
+                                    (prepare-for-db nil)))
+           (account-ignored-p   (user-ignored-p account-id))
+           (status-ignored-p    (status-ignored-p id folder timeline)))
       (when (not (and skip-ignored-p
                       (or status-ignored-p
                           account-ignored-p)))
@@ -1390,7 +1438,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
                                           rendered-text
                                           actual-visibility
                                           actual-sensitive
-                                          spoiler-text
+                                          actual-spoiler-text
                                           reblogs-count
                                           favourites-count
                                           url
@@ -1860,15 +1908,26 @@ the message identified by the tuple."
                                                                 (cdr b)))))))
     results))
 
-(defun mention-local->global-alist ()
+(defun all-mentioned-accounts ()
   "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
-  (let* ((query (select (:username :acct) (from +table-account+)))
+  (let* ((query (select (:username :acct) (from +table-mention+)))
          (rows  (fetch-all-rows query)))
-    (loop for row in rows collect
-                          (let ((local-name (db-getf row :username))
-                                (username   (db-getf row :acct)))
-                            (cons (msg-utils:add-mention-prefix local-name)
-                                  (msg-utils:add-mention-prefix username))))))
+    (loop for row in rows
+          collect
+          (let ((local-name (db-getf row :username))
+                (username   (db-getf row :acct)))
+            (cons (msg-utils:add-mention-prefix local-name)
+                  (msg-utils:add-mention-prefix username))))))
+
+(defun mentioned-username->account (username &key (add-mention-prefix t))
+  "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
+  (let* ((query (select :acct
+                  (from +table-mention+)
+                  (where (:= :username username))))
+         (acct  (second (fetch-single query))))
+    (if add-mention-prefix
+        (msg-utils:add-mention-prefix acct)
+        acct)))
 
 (defmacro gen-access-message-row (name column
                                   &key
@@ -3118,7 +3177,7 @@ conversation removed (default: remove)"
   (query (make-delete +table-cache+
              (:= :key key))))
 
-(defun cache-expired-p (key &key (days-in-the-past (swconf:config-purge-cage-days-offset)))
+(defun cache-expired-p (key &key (days-in-the-past (swconf:config-purge-cache-days-offset)))
   "Return non  nil if the last  time the cache was  accessed was older
 than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)'"
   (let ((row (cache-get key)))

src/gempub.lisp

@@ -57,8 +57,12 @@
                         gempub-version
                         gempub-cover))
 
-(defrule gempub-entry (and gempub-key (? gempub-blanks) gempub-key-value-separator
-                           (? gempub-blanks) gempub-value #\NewLine)
+(defrule linebreak (or #\NewLine #\Return))
+
+(defrule gempub-entry (or (and gempub-key (? gempub-blanks) gempub-key-value-separator
+                               (? gempub-blanks) gempub-value (+ linebreak))
+                          (and gempub-key (? gempub-blanks) gempub-key-value-separator
+                               (? gempub-blanks) gempub-value))
   (:function (lambda (a)  (list (first a) (fifth a)))))
 
 (defrule gempub-metadata (* gempub-entry)
@@ -79,7 +83,10 @@
       (when (find +metadata-entry-name+ entries :test #'String=)
         (when-let ((metadata-raw (os-utils:unzip-single-file zip-file
                                                              +metadata-entry-name+)))
-          (parse 'gempub-metadata metadata-raw))))))
+          (handler-case
+              (parse 'gempub-metadata metadata-raw)
+            (error (e)
+              (error "Error parsing metadata from file ~s: ~a" zip-file e))))))))
 
 (defun save-metadata (zip-file)
   (when-let ((metadata (extract-metadata zip-file)))

src/gui/client/main-window.lisp

@@ -236,7 +236,8 @@
                                                                  :aborting-function
                                                                  #'aborting-function
                                                                  :ignore-certificate-expiration
-                                                                 ignore-certificate-expiration)))))
+                                                                 ignore-certificate-expiration))
+                                          :name "stream thread")))
           (setf (fetching-thread stream-wrapper) stream-thread)
           stream-wrapper)))))
 
@@ -491,7 +492,7 @@
                                   :title (_ "Redirection")
                                   :parent main-window)
                (let ((redirect-iri (if (iri:absolute-url-p meta)
-                                       meta
+                                       (remove-standard-port meta)
                                        (absolutize-link iri meta))))
                  (slurp-iri redirect-iri main-window))))
             ((gemini-client:header-success-p status-code)
@@ -1023,6 +1024,14 @@ local file paths."
                    :font (gui-conf:gemini-preformatted-text-font-configuration))
     (set-text-gemtext main-window lines)))
 
+(defun ask-for-search (criteria main-window)
+  (when (gui:ask-yesno (format nil
+                               (_ "No such file or directory: ~s, search gemspace instead?")
+                               criteria)
+                       :title (_ "Question")
+                       :parent main-window)
+    (open-search-iri criteria main-window)))
+
 (defun open-local-path (path main-window &key (force-rendering nil))
   (cond
     ((fs:file-exists-p path)
@@ -1056,11 +1065,7 @@ local file paths."
        (set-address-bar-text main-window file-path)
        (open-local-path file-path main-window)))
     (t
-     (when (gui:ask-yesno (format nil (_ "No such file or directory: ~s, search gemspace instead?")
-                                  path)
-                           :title (_ "Error")
-                           :parent main-window)
-        (open-search-iri path main-window)))))
+     (ask-for-search path main-window))))
 
 (defun render-gemtext-string (main-window parsed-lines &key (links-path-prefix ""))
   (ev:with-enqueued-process-and-unblock ()
@@ -1166,25 +1171,30 @@ local file paths."
           ((or (gemini-parser:gemini-iri-p actual-iri)
                needs-proxy)
            (let ((stream-frame (stream-frame main-window)))
+             ;; note: keeps  this call before  'start-stream-iri'; the
+             ;; latter   will   recursively  call   'open-iri'   (this
+             ;; function) if a redirect is  met, and the procedures to
+             ;; delete and  repopulate stream frames  gets interleaved
+             ;; in  nodgui because  of  the same  procedure called  in
+             ;; 'slurp-gemini-stream', but in a different thread.
+             (client-stream-frame::refresh-all-streams
+              (client-stream-frame::table stream-frame))
              (start-stream-iri (iri-ensure-path actual-iri)
                                main-window
                                use-cache
                                :ignore-certificate-expiration nil
-                               :status status)
-             (client-stream-frame::refresh-all-streams
-              (client-stream-frame::table stream-frame))))
+                               :status status)))
+          ((iri:absolute-url-p iri)
+           (client-os-utils:open-resource-with-external-program main-window iri))
           ((or (fs:file-exists-p actual-iri)
                (fs:directory-exists-p actual-iri))
            (initialize-ir-lines main-window)
            (open-local-path (iri:path parsed-iri) main-window))
           (t
-           (client-os-utils:open-resource-with-external-program main-window actual-iri))))
+           (ask-for-search iri main-window))))
     (esrap:esrap-parse-error (e)
       (declare (ignore e))
-      (when (gui:ask-yesno (_ "Invalid address, perform a search using your input?")
-                           :title (_ "Invalid address")
-                           :parent main-window)
-        (open-search-iri iri main-window)))
+      (ask-for-search iri main-window))
     (error (e)
       (gui-goodies:notify-request-error e))))
 
@@ -1231,23 +1241,26 @@ local file paths."
 
 (defun slurp-non-text-data (main-window iri &key (try-to-open t))
   (declare (optimize (debug 0) (speed 3)))
-  (labels ((wait-until-download-complete (stream-info support-file)
+  (labels ((stream-completed-p (stream-info)
+             (string-equal (getf stream-info :stream-status)
+                           :completed))
+           (wait-until-download-complete (stream-info support-file)
              (declare (optimize (debug 0) (speed 3)))
-             (if (string-equal (getf stream-info :stream-status)
-                               :completed)
+             (if (stream-completed-p stream-info)
                  (if try-to-open
                      (client-os-utils:open-resource-with-external-program main-window support-file)
                      (values (getf stream-info :support-file)
                              (getf stream-info :meta)))
                  (wait-enough-data)))
-           (buffer-filled-enough-to-open-p (buffer-size read-so-far)
+           (buffer-filled-enough-to-open-p (buffer-size read-so-far stream-info)
              (declare (optimize (debug 0) (speed 3)))
              (declare (fixnum buffer-size read-so-far))
              (let ((filled-configuration-threshold (and buffer-size
                                                         (> read-so-far buffer-size))))
                (or filled-configuration-threshold
                    (> read-so-far
-                      swconf:+buffer-minimum-size-to-open+))))
+                      swconf:+buffer-minimum-size-to-open+)
+                   (stream-completed-p stream-info))))
            (wait-enough-data ()
              (declare (optimize (debug 0) (speed 3)))
              (let* ((stream-info
@@ -1255,8 +1268,8 @@ local file paths."
                                                             1
                                                             ev:+maximum-event-priority+
                                                             iri))
-                    (read-so-far  (getf stream-info :octet-count -1))
-                    (support-file (getf stream-info :support-file)))
+                    (read-so-far   (getf stream-info :octet-count -1))
+                    (support-file  (getf stream-info :support-file)))
                (multiple-value-bind (program-exists y wait-for-download)
                    (swconf:link-regex->program-to-use support-file)
                  (declare (ignore y))
@@ -1265,7 +1278,9 @@ local file paths."
                              (not try-to-open))
                          (wait-until-download-complete stream-info support-file)
                          (let ((buffer-size (swconf:link-regex->program-to-use-buffer-size support-file)))
-                           (if (buffer-filled-enough-to-open-p buffer-size read-so-far)
+                           (if (buffer-filled-enough-to-open-p buffer-size
+                                                               read-so-far
+                                                               stream-info)
                                (client-os-utils:open-resource-with-external-program main-window
                                                                                     support-file)
                                (wait-enough-data))))
@@ -1372,11 +1387,12 @@ local file paths."
                                 :title (_ "Redirection")
                                 :parent main-window)
              (let ((redirect-iri (if (iri:absolute-url-p meta)
-                                     meta
+                                     (remove-standard-port meta)
                                      (absolutize-link iri meta))))
-               (start-stream-iri redirect-iri main-window use-cache
-                                 :status status
-                                 :ignore-certificate-expiration ignore-certificate-expiration))))
+               (open-iri redirect-iri
+                         main-window
+                         t
+                         :status status))))
           ((gemini-client:header-success-p status-code)
            (cond
              ((eq status +stream-status-streaming+)

src/gui/client/program-events.lisp

@@ -25,7 +25,8 @@
         (make-thread (lambda ()
                           (let ((gui:*wish* gui-goodies:*gui-server*))
                             (loop while (events-loop-running-p) do
-                              (ev:dispatch-program-events-or-wait)))))))
+                              (ev:dispatch-program-events-or-wait))))
+                     :name "GUI events loop")))
 
 (defmacro with-enqueue-request ((method-name id &rest args) &body on-error)
   `(ev:with-enqueued-process-and-unblock ()

src/gui/client/stream-frame.lisp

@@ -25,7 +25,8 @@
                                                           :text  iri
                                                           :column-values
                                                           (list stream-status
-                                                                (to-s (getf row :octet-count)))
+                                                                (to-s (getf row
+                                                                            :octet-count)))
                                                           :index gui:+treeview-last-index+)))
         (gui:treeview-insert-item tree :item tree-row)))
     (gui:treeview-refit-columns-width (gui-goodies:tree stream-table))

src/gui/server/json-rpc-communication.lisp

@@ -71,4 +71,6 @@
         (error (e)
           (send-to-client (format nil (_ "Error: ~a~%") e))
           (setf *stop-server* t))))
+    (fs:clean-temporary-directories)
+    (fs:clean-temporary-files)
     (send-to-client "Bye!")))

src/html-utils.lisp

@@ -121,7 +121,7 @@
                           (quote-prefix "> ") (list-item-prefix "* "))
   "Transform html to text, note that if `add-link-footnotes` is non nil footnotes that marks html link in the text are added aftere the body of the message
 
-This function uses a library that transform html5 text into s-expressions um the form
+This function uses a library that transform html5 text into s-expressions in the form
 
 '(name (attributes) children*)
 

src/message-rendering-utils.lisp

@@ -41,27 +41,46 @@
         (when (mention-p first-mention)
           first-mention)))))
 
+(defun line-find-all-usernames (message-line)
+  (let ((words (split-words message-line)))
+    (mapcar (lambda (a) (subseq a (length +mention-prefix+))) ; remove the @
+            (remove-if-not (lambda (word)
+                             (cl-ppcre:scan (strcat "^" +mention-prefix+) word))
+                           words))))
+
+(defun usernames->usernames-table (message)
+  "Returns a list of pairs ('@'username . '@'acct)."
+  (let ((usernames '()))
+    (loop for line in (split-lines message)
+          do
+             (let ((usernames-in-line (line-find-all-usernames line)))
+               (setf usernames
+                     (concatenate 'list
+                                  usernames
+                                  usernames-in-line))))
+    (mapcar (lambda (username)
+              (cons (add-mention-prefix username)
+                    (db:mentioned-username->account username)))
+            usernames)))
+
 (defun local-mention->acct (text-line usernames-table)
   "Substitute in  `text-line' '@user' with '@user@server',  if '@user'
   is found as key in the alist `usernames-table'"
-  (flet ((find-all-username (key)
-           (let ((found (mapcar #'cdr
-                                (remove-if-not (lambda (a) (string= (car a) key))
-                                               usernames-table))))
-             (join-with-strings found ", "))))
-    (let ((results text-line)
-          (local-mention-prefix      (strcat " " +mention-prefix+))
-          (local-mention-temp-prefix (strcat " " +temp-mention-prefix+)))
-      (setf results (regex-replace-all local-mention-prefix
-                                       results
-                                       local-mention-temp-prefix))
-      (loop for pair in usernames-table do
-           (when-let* ((local-mention             (car pair))
-                       (local-mention-re          (strcat " " local-mention))
-                       (actual-mention            (strcat " "
-                                                          (find-all-username local-mention))))
-             (setf results (regex-replace-all local-mention-re results actual-mention))))
-      results)))
+  (let ((results text-line))
+    (loop for (local-mention . actual-mention) in usernames-table do
+      (let ((local-mention-re (strcat "(\\s|^)" local-mention)))
+        (setf results (regex-replace-all local-mention-re
+                                         results
+                                         (strcat " " actual-mention)))))
+    results))
+
+(defun expand-mention (text)
+  (let ((mentioned-users-table (usernames->usernames-table text)))
+    (with-output-to-string (stream)
+      (loop for line in (text-utils:split-lines text) do
+        (let ((line-fixed-mentions (local-mention->acct line mentioned-users-table)))
+          (write-sequence line-fixed-mentions stream)
+          (format stream "~%"))))))
 
 (defun crypto-message-destination-user (message-data)
   (with-accessors ((body       sending-message:body)
@@ -198,8 +217,11 @@
 
 (defgeneric message-original->text-body (object &key &allow-other-keys))
 
-(defmethod message-original->text-body ((object string) &key &allow-other-keys)
+(defmethod message-original->text-body ((object string)
+                                        &key (add-link-footnotes t)
+                                        &allow-other-keys)
   (let* ((raw-body (html-utils:html->text object
+                                          :add-link-footnotes add-link-footnotes
                                           :quote-prefix (swconf:message-window-quote-prefix)
                                           :list-item-prefix (swconf:message-window-bullet-prefix))))
     (emoji-shortcodes:emojify raw-body)))

src/package.lisp

@@ -965,6 +965,7 @@
    :next-in-history
    :most-recent-history-id
    :purge-history
+   :purge-post-mentions
    :history-prompt->values
    :all-poll-options
    :find-poll
@@ -986,6 +987,8 @@
    :message-children
    :message-root->tree
    :message->thread-users
+   :all-mentioned-accounts
+   :mentioned-username->account
    :message-id->tree
    :message-from-timeline-folder-message-index
    :message-index->tree
@@ -1478,7 +1481,8 @@
    :config-post-allowed-language
    :config-post-comment-prefix
    :config-purge-history-days-offset
-   :config-purge-cage-days-offset
+   :config-purge-cache-days-offset
+   :config-purge-post-mention-days-offset
    :config-notification-life
    :config-gemini-fragment-as-regex-p
    :config-notify-window-geometry
@@ -2425,8 +2429,10 @@
   (:export
    :+temp-mention-prefix+
    :add-mention-prefix
+   :usernames->usernames-table
    :strip-mention-prefix
    :local-mention->acct
+   :expand-mention
    :crypto-message-destination-user
    :maybe-crypt-message
    :attachment-type->description

src/program-events.lisp

@@ -2092,7 +2092,8 @@
 (defmethod process-event ((object edit-status-event))
   (with-accessors ((status-id payload)) object
     (when-let* ((status        (db:find-status-id status-id))
-                (text          (db:row-message-rendered-text status))
+                (text          (msg-utils:message-original->text-body (db:row-message-content status)
+                                                                      :add-link-footnotes nil))
                 (status-id     (db:row-message-status-id status))
                 (folder        (db:row-message-folder status))
                 (timeline      (db:row-message-timeline status))
@@ -2102,7 +2103,8 @@
                                 :direction         :output
                                 :if-exists         :supersede
                                 :if-does-not-exist :create)
-          (write-sequence text stream))
+          (let ((mentioned-users-text (msg-utils:expand-mention text)))
+            (write-sequence mentioned-users-text stream)))
         (croatoan:end-screen)
         (tui:with-notify-errors
           (os-utils:open-with-editor temp-file))

src/scheduled-events.lisp

@@ -72,6 +72,9 @@
 (gen-at-boot-function purge-history
   (db:purge-history))
 
+(gen-at-boot-function purge-mentions
+  (db:purge-post-mentions))
+
 (gen-at-boot-function refresh-gemlog-posts
   (when (swconf:gemini-update-gemlog-at-start-p)
     (ui:gemlog-refresh-all)))
@@ -96,6 +99,7 @@
   (refresh-gemlog-subscriptions ticks)
   (purge-gemlog-entries ticks)
   (purge-history)
+  (purge-mentions)
   (refresh-gemlog-posts)
   (sync-gempub-library)
   (look-for-announcement-on-boot))

src/software-configuration.lisp

@@ -669,6 +669,8 @@
                    language
                    purge-history-days-offset
                    purge-cache-days-offset
+                   purge-gemlog-seen-post-days-offset
+                   purge-post-mention-days-offset
                    mentions
                    montage
                    search-engine)
@@ -1077,23 +1079,28 @@
                    +key-comment-line+
                    +key-prefix+)
 
+(defun transform-purge-directive-value (a)
+  (* -1
+     (abs (num:safe-parse-number a
+                                 :fix-fn (lambda (e)
+                                           (declare (ignore e))
+                                           -100)))))
+
 (gen-simple-access (purge-history-days-offset
-                    :transform-value-fn
-                    (lambda (a)
-                      (num:safe-parse-number a
-                                             :fix-fn (lambda (e)
-                                                       (declare (ignore e))
-                                                       100))))
+                    :transform-value-fn transform-purge-directive-value)
                    +key-purge-history-days-offset+)
 
-(gen-simple-access (purge-cage-days-offset
-                    :transform-value-fn
-                    (lambda (a)
-                      (num:safe-parse-number a
-                                             :fix-fn (lambda (e)
-                                                       (declare (ignore e))
-                                                       100))))
-                   +key-purge-history-days-offset+)
+(gen-simple-access (purge-cache-days-offset
+                    :transform-value-fn transform-purge-directive-value)
+                   +key-purge-cache-days-offset+)
+
+(gen-simple-access (purge-gemlog-seen-post-days-offset
+                    :transform-value-fn transform-purge-directive-value)
+                   +key-purge-gemlog-seen-post-days-offset+)
+
+(gen-simple-access (purge-post-mention-days-offset
+                    :transform-value-fn transform-purge-directive-value)
+                   +key-purge-post-mention-days-offset+)
 
 (gen-simple-access (notification-life
                     :transform-value-fn

src/text-utils.lisp

@@ -100,7 +100,7 @@
   (babel:string-to-octets s :errorp suppress-errors-p))
 
 (defun clean-unprintable-chars (string)
-  (cl-ppcre:scan-to-strings "[\\p{Letter}\\p{Number}\\p{Punctuation}]+" string))
+  (cl-ppcre:regex-replace-all "\\p{C}" string ""))
 
 (defun strcat (&rest chunks)
   (declare (optimize (debug 0) (safety 0) (speed 3)))

src/ui-goodies.lisp

@@ -1350,7 +1350,7 @@ It an existing file path is provided the command will refuse to run."
                              exceeding)
                          exceeding)))
 
-(defun compose-message (&key timeline folder reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
+(defun compose-message (&key reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
   "Compose a new message"
   (setf *message-to-send* (make-instance 'sending-message:message-ready-to-send
                                          :visibility visibility
@@ -1381,28 +1381,22 @@ It an existing file path is provided the command will refuse to run."
                ;; in db (folder, timeline).
                (when-let* ((message        (db:find-message-id reply-id))
                            (reply-username (db:row-message-username message))
-                           (quoted-text    (db:row-message-rendered-text message))
-                           (lines          (split-lines quoted-text))
+                           (rendered-text  (db:row-message-rendered-text message))
+                           (lines          (split-lines rendered-text))
                            (quote-mark     (swconf:quote-char))
-                           (quoted-lines   (mapcar (lambda (a) (strcat quote-mark a))
-                                                   lines))
-                           (thread-users   (db:message->thread-users timeline
-                                                                     folder
-                                                                     reply-id
-                                                                     :local-name-prefix
-                                                                     message-rendering-utils:+temp-mention-prefix+
-                                                                     :acct-prefix
-                                                                     +mention-prefix+)))
-                 (with-open-file (stream file
-                                         :if-exists    :append
-                                         :direction    :output
-                                         :element-type 'character)
+                           (quoted-text    (strcat quote-mark
+                                                   (join-with-strings lines
+                                                                      (format nil
+                                                                              "~%~a"
+                                                                              quote-mark)))))
+                 (with-open-file (stream
+                                  file
+                                  :if-exists    :append
+                                  :direction    :output
+                                  :element-type 'character)
                    (format stream "~a~%" (msg-utils:add-mention-prefix reply-username))
-                   (loop for line in quoted-lines do
-                        (let ((line-fixed-mentions
-                               (message-rendering-utils:local-mention->acct line
-                                                                            thread-users)))
-                          (format stream "~a~%" line-fixed-mentions)))))))
+                   (let ((mentioned-users-text (msg-utils:expand-mention quoted-text)))
+                     (write-sequence mentioned-users-text stream))))))
            (add-signature (file)
              (when-let ((signature (message-rendering-utils:signature)))
                (with-open-file (stream
@@ -1488,15 +1482,11 @@ It an existing file path is provided the command will refuse to run."
               (actual-message   (if (db:row-message-reblog-id selected-message)
                                     (db:find-message-id (db:row-message-reblog-id selected-message))
                                     selected-message))
-              (timeline         (db:row-message-timeline actual-message))
-              (folder           (thread-window:timeline-folder win))
               (username         (db:row-message-username   actual-message))
               (visibility       (db:row-message-visibility actual-message))
               (reply-id         (actual-author-message-id  actual-message)))
     (let* ((subject (db:row-message-subject actual-message)))
-      (compose-message :timeline   timeline
-                       :folder     folder
-                       :reply-id   reply-id
+      (compose-message :reply-id   reply-id
                        :subject    subject
                        :visibility visibility))))
 

tinmop.asd

@@ -18,7 +18,7 @@
 (defsystem :tinmop
   :author      "cage"
   :license     "GPLv3+"
-  :version     "0.9.9.14142135623"
+  :version     "0.9.9.141421356237-rc1"
   :pathname    "src"
   :serial      t
   :bug-tracker "https://codeberg.org/cage/tinmop/issues"