- [fediverse] moved from a single database for a single account to a databases for each account.

- [TUI] fixed checks of configuration file.

src/api-client.lisp

@@ -26,9 +26,12 @@
 (defparameter *client-lock* (make-lock)
   "The Lock for prevent race conditions when accessing the mastodon server")
 
-(define-constant +credentials-filename+ "client"    :test #'string=
+(defun credentials-filename ()
-                 :documentation   "The   name   of  the   file   where
+  "The name of the file where credentials are stored."
-                 credentials are stored")
+  (text-utils:strcat (swconf:current-username)
+                     "@"
+                     (swconf:current-server-name)
+                     ".credentials"))
 
 (define-constant +protocol-scheme+      "https://" :test #'string=
                  :documentation "The  scheme of the protocol  that the
@@ -37,7 +40,7 @@
 (defun make-base-slot ()
   "Makes  the  'base'  slots   for  credential,  used  in  credentials
 initform."
-  (strcat +protocol-scheme+ (swconf:config-server-name)))
+  (strcat +protocol-scheme+ (swconf:current-server-name)))
 
 (defclass credentials ()
   ((base
@@ -70,14 +73,14 @@ initform."
 
 (defun dump-credentials ()
   "Serialize `*credential*' to disk"
-  (let ((resource-file (res:get-data-file +credentials-filename+)))
+  (let ((resource-file (res:get-data-file (credentials-filename))))
     (fs:dump-sequence-to-file (serialize *credentials*)
                               resource-file)))
 
 (defun forget-credentials ()
   "Remove credentials data file"
   (conditions:with-default-on-error (nil)
-    (let ((resource-file (res:get-data-file +credentials-filename+)))
+    (let ((resource-file (res:get-data-file (credentials-filename))))
       (fs:delete-file-if-exists resource-file))))
 
 (defun credentials-complete-p ()
@@ -178,7 +181,7 @@ authorizations was performed with success."
   "Convenience funtion to build a `api-client' instance
 
 Returns nil if the user did not provided a server in the configuration file"
-  (when (text-utils:string-not-empty-p (swconf:config-server-name))
+  (when (text-utils:string-not-empty-p (swconf:current-server-name))
     (make-instance 'api-client
                    :website  +package-url+
                    :base     (make-base-slot)
@@ -201,7 +204,7 @@ Returns nil if the user did not provided a server in the configuration file"
               (ui:error-dialog-immediate
                (format nil
                        (_ "Credential invalid. Try to remove ~a and restart the software to authenticate again")
-                       (res:get-data-file +credentials-filename+))))))
+                       (res:get-data-file (credentials-filename)))))))
         (multiple-value-bind (server-socket server-port)
             (open-catch-code-socket)
           (setf *client* (make-default-client))
@@ -964,7 +967,7 @@ and day is current time)"
                             (lambda (e)
                               (declare (ignore e))
                               (invoke-restart 'res:return-home-filename))))
-             (res:get-data-file +credentials-filename+))))
+             (res:get-data-file (credentials-filename)))))
     (let ((resource-file (credentials-filename)))
       (if (not (fs:file-exists-p resource-file))
           (progn

src/constants.lisp

@@ -122,8 +122,8 @@ General Public License for more details."
 
 (define-constant +mime-type-text+               "text/plain"  :test #'string=)
 
-(define-constant +db-file+                      "db.sqlite3"  :test #'string=
+(define-constant +db-file-extension+            "sqlite3"     :test #'string=
-                 :documentation "the filename of the database")
+                 :documentation "the extension filename of the databases")
 
 (define-constant +json-true+                    "true"        :test #'string=)
 

src/db-utils.lisp

@@ -227,11 +227,25 @@ example:
                                    (from table)))))
         :ct))
 
+(defun db-current-file-name ()
+  (concatenate 'string
+               (swconf:current-username)
+               "@"
+               (swconf:current-server-name)
+               "."
+               +db-file-extension+))
+
 (defun db-path ()
   (uiop:unix-namestring (concatenate 'string
                                      (res:home-datadir)
                                      "/"
-                                     +db-file+)))
+                                     (db-current-file-name))))
+
+(defun db-path* ()
+  (uiop:unix-namestring (concatenate 'string
+                                     (res:home-datadir)
+                                     "/"
+                                     "db.sqlite3")))
 
 (defun db-file-exists-p ()
   (fs:file-exists-p (db-path)))

src/gui/client/client-configuration.lisp

@@ -79,7 +79,7 @@
              (declare (ignore rest))
              (setf *client-configuration* all))))))
     (when perform-missing-value-check
-      (swconf:perform-missing-value-check file))
+      (swconf:perform-trivial-configuration-checks file))
     (if *client-configuration*
         (values *client-configuration* file)
         (error (format nil (_ "fatal error: The file ~a is empty") file)))))

src/main.lisp

@@ -120,19 +120,23 @@ etc.) happened"
       (multiple-value-bind (x configuration-file-path)
           (swconf:load-config-file swconf:+shared-conf-filename+)
         (declare (ignore x))
-        (swconf:perform-missing-value-check configuration-file-path))
+        (swconf:perform-trivial-configuration-checks configuration-file-path))
     (error (e)
       (format *error-output* "~a~%" e)
       (os-utils:exit-program 1)))
-  (handler-bind ((error
+  (handler-case
-                   (lambda (e)
+      (progn
-                     (format *error-output*
+        (swconf:load-config-file swconf:+conf-filename+ t)
-                             (_ "Non fatal error~%~a~%Tinmop will add an empty file for you in ~a. This file will be enough to use the program as a gemini client but to connect to pleroma the file must be properly filled.~%Consult the manpage ~a(1) for more details")
+        (swconf:set-current-username-and-server))
-                             (res:home-confdir)
+    (error (e)
-                             e
+      (format *error-output*
-                             +program-name+)
+              (_ "Configuration error~%~a~%Tinmop will create  an empty file for you in ~a (if such file does not exists). This file will be enough to use the program as a gemini client but to connect to pleroma the file must be properly filled.~2%Consult the manpage ~a(1) for more details.~2%If you already wrote a configuration file, check the error printed below, try to fix the configuration file and restart ~a.~%")
-                     (invoke-restart 'res:create-empty-in-home))))
+              e
-    (swconf:load-config-file swconf:+conf-filename+)))
+              (res:home-confdir)
+              +program-name+
+              +program-name+)
+      (res:create-empty-file-in-home swconf:+conf-filename+)
+      (os-utils:exit-program 1))))
 
 (defun shared-init (&key (verbose t))
   (num:lcg-set-seed)
@@ -255,28 +259,29 @@ etc.) happened"
 
 (defun main ()
   "The entry point function of the program"
-  (let ((first-time-starting (not (db-utils:db-file-exists-p))))
+  (init-i18n)
-    (init-i18n)
+  (res:init)
-    (res:init)
+  (command-line:manage-opts)
-    (command-line:manage-opts)
+  (cond
-    (cond
+    (command-line:*start-dummy-server*
-      (command-line:*start-dummy-server*
+     (gemini-dummy-server:start))
-       (gemini-dummy-server:start))
+    (command-line:*rpc-server-mode*
-      (command-line:*rpc-server-mode*
+     (db-utils:with-ready-database (:connect nil)
-       (db-utils:with-ready-database (:connect nil)
+       (rpc-server-init)))
-         (rpc-server-init)))
+    (command-line:*rpc-client-mode*
-      (command-line:*rpc-client-mode*
+     (rpc-client-init)
-       (rpc-client-init)
+     (json-rpc-communication::start-client)
-       (json-rpc-communication::start-client)
+     (client-main-window:init-main-window command-line:*net-address*))
-       (client-main-window:init-main-window command-line:*net-address*))
+    (command-line:*print-lisp-dependencies*
-      (command-line:*print-lisp-dependencies*
+     (misc:all-program-dependencies t))
-       (misc:all-program-dependencies t))
+    (command-line:*script-file*
-      (command-line:*script-file*
+     (load-script-file))
-       (load-script-file))
+    (t
-      (t
+     (let ((croatoan::*debugger-hook* #'(lambda (c h)
-       (let ((croatoan::*debugger-hook* #'(lambda (c h)
+                                          (declare (ignore h))
-                                            (declare (ignore h))
+                                          (c:end-screen)
-                                            (c:end-screen)
+                                          (print c))))
-                                            (print c))))
+
-         (tui-init)
+       (tui-init)
-         (run first-time-starting))))))
+        (let ((first-time-starting (not (db-utils:db-file-exists-p))))
+          (run first-time-starting))))))

src/package.lisp

@@ -55,7 +55,7 @@
    :+mime-type-png+
    :+mime-type-html+
    :+mime-type-text+
-   :+db-file+
+   :+db-file-extension+
    :+fps+
    :+command-window-height+
    :+starting-init-file+
@@ -517,6 +517,7 @@
    :create-empty-in-home
    :get-config-file
    :get-sys-config-file
+   :create-empty-file-in-home
    :get-data-file
    :get-data-dir))
 
@@ -1368,7 +1369,7 @@
    :attributes
    :parse-config
    :parse
-   :perform-missing-value-check
+   :perform-trivial-configuration-checks
    :load-config-file
    :gen-simple-access
    :access-non-null-conf-value
@@ -1437,8 +1438,9 @@
    :config-gemini-fragment-as-regex-p
    :config-notify-window-geometry
    :config-notification-icon
-   :config-server-name
+   :current-username
-   :config-username
+   :current-server-name
+   :set-current-username-and-server
    :config-password-echo-character
    :config-win-focus-mark
    :config-gopher-line-prefix-directory

src/resources-utils.lisp

@@ -43,6 +43,9 @@
   (fs:make-directory (home-datadir))
   (fs:make-directory (home-confdir)))
 
+(defun create-empty-file-in-home (path)
+  (fs:create-file path :skip-if-exists t))
+
 (defun get-resource-file (system-dir home-dir path)
   (let ((system-file (fs:cat-parent-dir system-dir path))
         (home-file   (fs:cat-parent-dir home-dir   path)))
@@ -60,7 +63,7 @@
            (return-system-filename ()
              system-file)
            (create-empty-in-home  ()
-             (fs:create-file home-file :skip-if-exists t)
+             (create-empty-file-in-home home-file)
              (get-resource-file system-dir home-dir path))))))))
 
 (defun get-resource-dir (system-dir home-dir path)

src/software-configuration.lisp

@@ -303,11 +303,13 @@
 
 (defrule server-assign
     (and server-key blanks assign blanks generic-value blanks)
-  (:function remove-if-null))
+  (:function (lambda (a)
+               (list (first a) (fifth a)))))
 
 (defrule username-assign
     (and username-key blanks assign blanks generic-value blanks)
-  (:function remove-if-null))
+  (:function (lambda (a)
+               (list (first a) (fifth a)))))
 
 (define-constant +buffer-minimum-size-to-open+ (expt 1024 2) :test #'=
   :documentation "Minimum size of the saved contents (non gemini text)
@@ -646,14 +648,16 @@
                    mentions
                    montage)
 
-(defun perform-missing-value-check (file)
+(defun perform-trivial-configuration-checks (file)
   (handler-case
-      (trivial-configuration-missing-value-check)
+      (progn
+        (trivial-configuration-missing-value-check)
+        (trivial-configuration-checks))
     (error (e)
       (error (format nil "Error while loading the file ~a~%~a~%" file e)))))
 
 (defun load-config-file (&optional (virtual-filepath +conf-filename+)
-                           (perform-missing-value-check nil))
+                           (perform-checks nil))
   (let* ((file (res:get-config-file virtual-filepath))
          (tree (parse-config (fs:namestring->pathname file))))
     (loop for entry in tree do
@@ -665,7 +669,9 @@
                (eq +key-ignore-user-boost-re+ key)
                (eq +key-ignore-tag-re+ key)
                (eq +key-open-link-helper+ key)
-               (eq +key-post-allowed-language+ key))
+               (eq +key-post-allowed-language+ key)
+               (eq +key-server+ key)
+               (eq +key-username+ key))
            (setf (access:accesses *software-configuration* key)
                  (append (access:accesses *software-configuration* key)
                          (list value))))
@@ -676,8 +682,8 @@
                (apply #'access:set-accesses value *software-configuration* key)
              (declare (ignore rest))
              (setf *software-configuration* all))))))
-    (when perform-missing-value-check
+    (when perform-checks
-      (perform-missing-value-check file))
+      (perform-trivial-configuration-checks file))
     (if *software-configuration*
         (values *software-configuration* file)
         (error (format nil (_ "fatal error: The file ~a is empty") file)))))
@@ -1100,6 +1106,11 @@
                             +key-notify-window+
                             +key-width+)))
 
+
+(defparameter *current-username*    nil)
+
+(defparameter *current-server-name* nil)
+
 (gen-simple-access (notification-icon)
                    +key-thread-window+
                    +key-modeline+
@@ -1112,6 +1123,41 @@
 (gen-simple-access (username)
                    +key-username+)
 
+(defun current-username ()
+  *current-username*)
+
+(defun current-server-name ()
+  *current-server-name*)
+
+(defun set-current-username-and-server (&optional username server-name)
+  (flet ((set-currents (username server-name)
+           (setf *current-username* username)
+           (setf *current-server-name*   server-name)))
+    (cond
+      ((not (or username
+                server-name))
+       (set-currents (first (config-username)) (first (config-server-name))))
+      ((and (text-utils:string-not-empty-p username)
+            (text-utils:string-not-empty-p server-name))
+       (let* ((position-all-usernames  (loop for pos from 0
+                                             for i in (config-username)
+                                             when (string= i username)
+                                               collect
+                                             pos))
+              (matched-server-position (loop named scanner
+                                             for i in position-all-usernames
+                                             when (string= (elt (config-server-name) i)
+                                                           server-name)
+                                               do (return-from scanner i))))
+         (if matched-server-position
+             (set-currents (elt (config-username) matched-server-position)
+                           (elt (config-server-name) matched-server-position))
+             (error "no matching server for user ~a" username))))
+      (t
+       (if username
+           (error "server name value can not be null")
+           (error "username value can not be null"))))))
+
 (gen-simple-access (password-echo-character)
                    +key-password-echo-character+)
 
@@ -1656,3 +1702,7 @@
                    #'config-announcements-separator)
         do
            (funcall fn)))
+
+(defun trivial-configuration-checks ()
+  (assert (length= (config-username)
+                   (config-server-name))))

src/thread-window.lisp

@@ -209,8 +209,8 @@
 
 (defun default-expander ()
   (list (cons "%" (lambda (w) (with-tuify-results (w) "%")))
-        (cons "s" (lambda (w) (with-tuify-results (w) (swconf:config-server-name))))
+        (cons "s" (lambda (w) (with-tuify-results (w) (swconf:current-server-name))))
-        (cons "u" (lambda (w) (with-tuify-results (w) (swconf:config-username))))
+        (cons "u" (lambda (w) (with-tuify-results (w) (swconf:current-username))))
         (cons "k" #'expand-timeline-type)
         (cons "f" #'expand-folder-name)
         (cons "h" #'expand-message-hashtags)