mirror of https://codeberg.org/cage/tinmop/
Compare commits
3 Commits
629cf8e784
...
608eacda77
Author | SHA1 | Date |
---|---|---|
cage | 608eacda77 | |
cage | c459c34dd1 | |
cage | 41511b70eb |
|
@ -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=
|
||||
:documentation "The name of the file where
|
||||
credentials are stored")
|
||||
(defun credentials-filename ()
|
||||
"The name of the file where 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
|
||||
|
|
|
@ -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=
|
||||
:documentation "the filename of the database")
|
||||
(define-constant +db-file-extension+ "sqlite3" :test #'string=
|
||||
:documentation "the extension filename of the databases")
|
||||
|
||||
(define-constant +json-true+ "true" :test #'string=)
|
||||
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))))
|
||||
|
|
|
@ -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
|
||||
(lambda (e)
|
||||
(format *error-output*
|
||||
(_ "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")
|
||||
(res:home-confdir)
|
||||
e
|
||||
+program-name+)
|
||||
(invoke-restart 'res:create-empty-in-home))))
|
||||
(swconf:load-config-file swconf:+conf-filename+)))
|
||||
(handler-case
|
||||
(progn
|
||||
(swconf:load-config-file swconf:+conf-filename+ t)
|
||||
(swconf:set-current-username-and-server))
|
||||
(error (e)
|
||||
(format *error-output*
|
||||
(_ "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.~%")
|
||||
e
|
||||
(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)
|
||||
(res:init)
|
||||
(command-line:manage-opts)
|
||||
(cond
|
||||
(command-line:*start-dummy-server*
|
||||
(gemini-dummy-server:start))
|
||||
(command-line:*rpc-server-mode*
|
||||
(db-utils:with-ready-database (:connect nil)
|
||||
(rpc-server-init)))
|
||||
(command-line:*rpc-client-mode*
|
||||
(rpc-client-init)
|
||||
(json-rpc-communication::start-client)
|
||||
(client-main-window:init-main-window command-line:*net-address*))
|
||||
(command-line:*print-lisp-dependencies*
|
||||
(misc:all-program-dependencies t))
|
||||
(command-line:*script-file*
|
||||
(load-script-file))
|
||||
(t
|
||||
(let ((croatoan::*debugger-hook* #'(lambda (c h)
|
||||
(declare (ignore h))
|
||||
(c:end-screen)
|
||||
(print c))))
|
||||
(tui-init)
|
||||
(run first-time-starting))))))
|
||||
(init-i18n)
|
||||
(res:init)
|
||||
(command-line:manage-opts)
|
||||
(cond
|
||||
(command-line:*start-dummy-server*
|
||||
(gemini-dummy-server:start))
|
||||
(command-line:*rpc-server-mode*
|
||||
(db-utils:with-ready-database (:connect nil)
|
||||
(rpc-server-init)))
|
||||
(command-line:*rpc-client-mode*
|
||||
(rpc-client-init)
|
||||
(json-rpc-communication::start-client)
|
||||
(client-main-window:init-main-window command-line:*net-address*))
|
||||
(command-line:*print-lisp-dependencies*
|
||||
(misc:all-program-dependencies t))
|
||||
(command-line:*script-file*
|
||||
(load-script-file))
|
||||
(t
|
||||
(let ((croatoan::*debugger-hook* #'(lambda (c h)
|
||||
(declare (ignore h))
|
||||
(c:end-screen)
|
||||
(print c))))
|
||||
|
||||
(tui-init)
|
||||
(let ((first-time-starting (not (db-utils:db-file-exists-p))))
|
||||
(run first-time-starting))))))
|
||||
|
|
|
@ -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
|
||||
:config-username
|
||||
:current-username
|
||||
:current-server-name
|
||||
:set-current-username-and-server
|
||||
:config-password-echo-character
|
||||
:config-win-focus-mark
|
||||
:config-gopher-line-prefix-directory
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
(perform-missing-value-check file))
|
||||
(when perform-checks
|
||||
(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))))
|
||||
|
|
|
@ -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 "u" (lambda (w) (with-tuify-results (w) (swconf:config-username))))
|
||||
(cons "s" (lambda (w) (with-tuify-results (w) (swconf:current-server-name))))
|
||||
(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)
|
||||
|
|
Loading…
Reference in New Issue