diff options
| -rwxr-xr-x | run-tests.sh | 2 | ||||
| -rw-r--r-- | src/config.lisp | 2 | ||||
| -rw-r--r-- | src/inline-bots.lisp | 18 | ||||
| -rw-r--r-- | src/main.lisp | 126 | ||||
| -rw-r--r-- | src/state.lisp | 99 | ||||
| -rw-r--r-- | src/tg/delete-message.lisp | 9 | ||||
| -rw-r--r-- | src/tg/get-me.lisp | 30 | ||||
| -rw-r--r-- | src/tg/method-macros.lisp | 14 | ||||
| -rw-r--r-- | src/tg/send-animation.lisp | 7 | ||||
| -rw-r--r-- | src/tg/send-message.lisp | 7 | ||||
| -rw-r--r-- | src/tg/set-my-name.lisp | 10 | ||||
| -rw-r--r-- | src/transport.lisp | 6 | ||||
| -rw-r--r-- | ukkoclot.asd | 1 |
13 files changed, 198 insertions, 133 deletions
diff --git a/run-tests.sh b/run-tests.sh index f8338b3..b2bbdb9 100755 --- a/run-tests.sh +++ b/run-tests.sh | |||
| @@ -7,6 +7,6 @@ set -eu | |||
| 7 | exec sbcl \ | 7 | exec sbcl \ |
| 8 | --disable-ldb --lose-on-corruption \ | 8 | --disable-ldb --lose-on-corruption \ |
| 9 | --noinform --noprint --non-interactive \ | 9 | --noinform --noprint --non-interactive \ |
| 10 | --eval '(asdf:load-system :ukkoclot/test/all)' \ | 10 | --eval '(asdf:load-system :ukkoclot/test/all :verbose t)' \ |
| 11 | --eval '(setf ukkoclot/test/all:*should-quit* t)' \ | 11 | --eval '(setf ukkoclot/test/all:*should-quit* t)' \ |
| 12 | --eval '(asdf:test-system :ukkoclot)' | 12 | --eval '(asdf:test-system :ukkoclot)' |
diff --git a/src/config.lisp b/src/config.lisp index 7d841a2..1a139c1 100644 --- a/src/config.lisp +++ b/src/config.lisp | |||
| @@ -20,7 +20,7 @@ | |||
| 20 | (in-package :ukkoclot/src/config) | 20 | (in-package :ukkoclot/src/config) |
| 21 | 21 | ||
| 22 | (defstruct config | 22 | (defstruct config |
| 23 | (lock (make-rw-lock :name "config's lock") :type rw-lock) | 23 | (lock (make-rw-lock :name "config's lock") :type rw-lock :read-only t) |
| 24 | (bot-name "Ukko's Clot" :type string) | 24 | (bot-name "Ukko's Clot" :type string) |
| 25 | (bot-token "123456789:ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghi" :type string) | 25 | (bot-token "123456789:ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghi" :type string) |
| 26 | (db-path #P"./data.db" :type (or pathname string)) | 26 | (db-path #P"./data.db" :type (or pathname string)) |
diff --git a/src/inline-bots.lisp b/src/inline-bots.lisp index 4f6a679..4361adb 100644 --- a/src/inline-bots.lisp +++ b/src/inline-bots.lisp | |||
| @@ -6,34 +6,33 @@ | |||
| 6 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 6 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 7 | (:import-from :conf) | 7 | (:import-from :conf) |
| 8 | (:import-from :log) | 8 | (:import-from :log) |
| 9 | (:import-from :ukkoclot/src/tg :send-message :try-delete-message) | 9 | (:import-from :state) |
| 10 | (:import-from :ukkoclot/src/state :bot-db) | ||
| 11 | (:local-nicknames (:db :ukkoclot/src/db)) | 10 | (:local-nicknames (:db :ukkoclot/src/db)) |
| 12 | (:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot)) | 11 | (:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot)) |
| 13 | (in-package :ukkoclot/src/inline-bots) | 12 | (in-package :ukkoclot/src/inline-bots) |
| 14 | 13 | ||
| 15 | (enable-f-strings) | 14 | (enable-f-strings) |
| 16 | 15 | ||
| 17 | (defun blacklist-inline-bot (bot inline-bot-id) | 16 | (defun blacklist-inline-bot (inline-bot-id) |
| 18 | "Blacklist the given bot. | 17 | "Blacklist the given bot. |
| 19 | 18 | ||
| 20 | No more messages about deleting its messages will be sent." | 19 | No more messages about deleting its messages will be sent." |
| 21 | (db:set-inline-bot-type (bot-db bot) inline-bot-id :blacklisted)) | 20 | (db:set-inline-bot-type (state:db) inline-bot-id :blacklisted)) |
| 22 | 21 | ||
| 23 | (defun whitelist-inline-bot (bot inline-bot-id) | 22 | (defun whitelist-inline-bot (inline-bot-id) |
| 24 | "Whitelist the given bot. | 23 | "Whitelist the given bot. |
| 25 | 24 | ||
| 26 | Its messages will no longer be deleted." | 25 | Its messages will no longer be deleted." |
| 27 | (db:set-inline-bot-type (bot-db bot) inline-bot-id :whitelisted)) | 26 | (db:set-inline-bot-type (state:db) inline-bot-id :whitelisted)) |
| 28 | 27 | ||
| 29 | (defun on-inline-bot (bot msg via) | 28 | (defun on-inline-bot (msg via) |
| 30 | (let ((ty (db:get-inline-bot-type (bot-db bot) (user-id via)))) | 29 | (let ((ty (db:get-inline-bot-type (state:db) (user-id via)))) |
| 31 | (or (eql ty :whitelisted) | 30 | (or (eql ty :whitelisted) |
| 32 | (prog1 nil | 31 | (prog1 nil |
| 33 | (log:info "Deleting an unallowed inline bot message from ~A ~A" | 32 | (log:info "Deleting an unallowed inline bot message from ~A ~A" |
| 34 | (user-username via) | 33 | (user-username via) |
| 35 | (user-id via)) | 34 | (user-id via)) |
| 36 | (try-delete-message bot msg) | 35 | (try-delete-message msg) |
| 37 | (unless (eql ty :blacklisted) | 36 | (unless (eql ty :blacklisted) |
| 38 | ;; Not explicitly blacklisted, notify dev group | 37 | ;; Not explicitly blacklisted, notify dev group |
| 39 | (let ((whitelist (make-inline-keyboard-button :text "Whitelist" | 38 | (let ((whitelist (make-inline-keyboard-button :text "Whitelist" |
| @@ -41,7 +40,6 @@ Its messages will no longer be deleted." | |||
| 41 | (blacklist (make-inline-keyboard-button :text "Blacklist" | 40 | (blacklist (make-inline-keyboard-button :text "Blacklist" |
| 42 | :callback-data #f"bbl:{(user-id via)}"))) | 41 | :callback-data #f"bbl:{(user-id via)}"))) |
| 43 | (send-message | 42 | (send-message |
| 44 | bot | ||
| 45 | :chat-id (conf:dev-group) | 43 | :chat-id (conf:dev-group) |
| 46 | :text #f"Deleted a message sent via inline bot @{(user-username via)} <code>{(user-id via)}</code>" | 44 | :text #f"Deleted a message sent via inline bot @{(user-username via)} <code>{(user-id via)}</code>" |
| 47 | :parse-mode html | 45 | :parse-mode html |
diff --git a/src/main.lisp b/src/main.lisp index caef651..fa7fab0 100644 --- a/src/main.lisp +++ b/src/main.lisp | |||
| @@ -8,10 +8,10 @@ | |||
| 8 | (:import-from :conf) | 8 | (:import-from :conf) |
| 9 | (:import-from :log) | 9 | (:import-from :log) |
| 10 | (:import-from :serapeum :drop) | 10 | (:import-from :serapeum :drop) |
| 11 | (:import-from :state :*state* :make-state) | ||
| 11 | (:import-from :str) | 12 | (:import-from :str) |
| 12 | (:import-from :ukkoclot/src/db :with-db) | 13 | (:import-from :ukkoclot/src/db :with-db) |
| 13 | (:import-from :ukkoclot/src/serializing :fixup-value) | 14 | (:import-from :ukkoclot/src/serializing :fixup-value) |
| 14 | (:import-from :ukkoclot/src/state :make-bot :bot-power-on) | ||
| 15 | (:import-from :ukkoclot/src/strings :escape-xml :is-tg-whitespace :is-tg-whitespace-str) | 15 | (:import-from :ukkoclot/src/strings :escape-xml :is-tg-whitespace :is-tg-whitespace-str) |
| 16 | (:local-nicknames | 16 | (:local-nicknames |
| 17 | (:jzon :com.inuoe.jzon)) | 17 | (:jzon :com.inuoe.jzon)) |
| @@ -26,7 +26,7 @@ | |||
| 26 | `(cond | 26 | `(cond |
| 27 | (*in-prod* | 27 | (*in-prod* |
| 28 | (handler-case (progn ,@body) ; lint:suppress redundant-progn | 28 | (handler-case (progn ,@body) ; lint:suppress redundant-progn |
| 29 | (error (err) (report-error bot ,evt err)))) | 29 | (error (err) (report-error ,evt err)))) |
| 30 | (t ,@body))) | 30 | (t ,@body))) |
| 31 | 31 | ||
| 32 | (defun main () | 32 | (defun main () |
| @@ -43,87 +43,82 @@ | |||
| 43 | (defun main-with-config () | 43 | (defun main-with-config () |
| 44 | (unwind-protect | 44 | (unwind-protect |
| 45 | (with-db (db (conf:db-path)) | 45 | (with-db (db (conf:db-path)) |
| 46 | (let ((bot (make-bot db))) | 46 | (setf *state* (make-state db)) |
| 47 | ;; TODO: Catch fatal errors & report them | 47 | ;; TODO: Catch fatal errors & report them |
| 48 | (wrapped-main bot))) | 48 | (wrapped-main)) |
| 49 | (log:info "We're done!"))) | 49 | (log:info "We're done!"))) |
| 50 | 50 | ||
| 51 | (defun wrapped-main (bot) | 51 | (defun wrapped-main () |
| 52 | (when *in-prod* | 52 | (when *in-prod* |
| 53 | (send-message bot :chat-id (conf:dev-group) :text "Initializing...")) | 53 | (send-message :chat-id (conf:dev-group) :text "Initializing...")) |
| 54 | (set-my-name bot :name (conf:bot-name)) | 54 | (set-my-name :name (conf:bot-name)) |
| 55 | (let ((gup-offset 0)) | 55 | (let ((gup-offset 0)) |
| 56 | (loop while (bot-power-on bot) do | 56 | (loop while (state:power-on) do |
| 57 | (let ((updates (get-updates bot :timeout 60 :offset gup-offset))) | 57 | (let ((updates (get-updates :timeout 60 :offset gup-offset))) |
| 58 | (loop for update across updates do | 58 | (loop for update across updates do |
| 59 | (unwind-protect | 59 | (unwind-protect |
| 60 | (progn | 60 | (progn |
| 61 | (when-let (msg (update-message update)) | 61 | (when-let (msg (update-message update)) |
| 62 | (reporty (msg) | 62 | (reporty (msg) |
| 63 | (on-message bot msg))) | 63 | (on-message msg))) |
| 64 | (when-let (cbq (update-callback-query update)) | 64 | (when-let (cbq (update-callback-query update)) |
| 65 | (reporty (cbq) | 65 | (reporty (cbq) |
| 66 | (on-callback-query bot cbq)))) | 66 | (on-callback-query cbq)))) |
| 67 | (setf gup-offset (1+ (update-update-id update))))))) | 67 | (setf gup-offset (1+ (update-update-id update))))))) |
| 68 | ;; One last getUpdates to make sure offset is stored on server | 68 | ;; One last getUpdates to make sure offset is stored on server |
| 69 | (get-updates bot :timeout 0 :limit 1 :offset gup-offset)) | 69 | (get-updates :timeout 0 :limit 1 :offset gup-offset)) |
| 70 | (send-message bot :chat-id (conf:dev-group) :text "Shutting down...")) | 70 | (send-message :chat-id (conf:dev-group) :text "Shutting down...")) |
| 71 | 71 | ||
| 72 | (defun on-callback-query (bot cb) | 72 | (defun on-callback-query (cb) |
| 73 | (let ((data (callback-query-data cb))) | 73 | (let ((data (callback-query-data cb))) |
| 74 | (cond ((and data | 74 | (cond ((and data |
| 75 | (str:starts-with-p "bbl:" data :ignore-case nil) | 75 | (str:starts-with-p "bbl:" data :ignore-case nil) |
| 76 | (= (user-id (callback-query-from cb)) | 76 | (= (user-id (callback-query-from cb)) |
| 77 | (conf:owner))) | 77 | (conf:owner))) |
| 78 | (let ((bot-id (read-from-string data t nil :start 4))) | 78 | (let ((bot-id (read-from-string data t nil :start 4))) |
| 79 | (blacklist-inline-bot bot bot-id)) | 79 | (blacklist-inline-bot bot-id)) |
| 80 | (when-let (msg (callback-query-message cb)) | 80 | (when-let (msg (callback-query-message cb)) |
| 81 | (delete-message bot | 81 | (delete-message :chat-id (message-chat-id msg) |
| 82 | :chat-id (message-chat-id msg) | ||
| 83 | :message-id (message-id msg))) | 82 | :message-id (message-id msg))) |
| 84 | (answer-callback-query bot | 83 | (answer-callback-query :callback-query-id (callback-query-id cb) |
| 85 | :callback-query-id (callback-query-id cb) | ||
| 86 | :text "OK")) | 84 | :text "OK")) |
| 87 | ((and data | 85 | ((and data |
| 88 | (str:starts-with-p "bwl:" data :ignore-case nil) | 86 | (str:starts-with-p "bwl:" data :ignore-case nil) |
| 89 | (= (user-id (callback-query-from cb)) | 87 | (= (user-id (callback-query-from cb)) |
| 90 | (conf:owner))) | 88 | (conf:owner))) |
| 91 | (let ((bot-id (read-from-string data t nil :start 4))) | 89 | (let ((bot-id (read-from-string data t nil :start 4))) |
| 92 | (whitelist-inline-bot bot bot-id)) | 90 | (whitelist-inline-bot bot-id)) |
| 93 | (when-let (msg (callback-query-message cb)) | 91 | (when-let (msg (callback-query-message cb)) |
| 94 | (delete-message bot | 92 | (delete-message :chat-id (message-chat-id msg) |
| 95 | :chat-id (message-chat-id msg) | ||
| 96 | :message-id (message-id msg))) | 93 | :message-id (message-id msg))) |
| 97 | (answer-callback-query bot | 94 | (answer-callback-query :callback-query-id (callback-query-id cb) |
| 98 | :callback-query-id (callback-query-id cb) | ||
| 99 | :text "OK")) | 95 | :text "OK")) |
| 100 | (t | 96 | (t |
| 101 | (log:info "Unrecognised callback query data: ~A" data) | 97 | (log:info "Unrecognised callback query data: ~A" data) |
| 102 | (answer-callback-query bot | 98 | (answer-callback-query :callback-query-id (callback-query-id cb) |
| 103 | :callback-query-id (callback-query-id cb) | ||
| 104 | :text "Unallowed callback query, don't press the button again" | 99 | :text "Unallowed callback query, don't press the button again" |
| 105 | :show-alert t))))) | 100 | :show-alert t))))) |
| 106 | 101 | ||
| 107 | 102 | ||
| 108 | (defun on-message (bot msg) | 103 | (defun on-message (msg) |
| 109 | (block nil | 104 | (block nil |
| 110 | (when-let (inline-bot (message-via-bot msg)) | 105 | (when-let (inline-bot (message-via-bot msg)) |
| 111 | (unless (on-inline-bot bot msg inline-bot) | 106 | (unless (on-inline-bot msg inline-bot) |
| 112 | (return))) | 107 | (return))) |
| 113 | 108 | ||
| 114 | (when-let (text (message-text msg)) | 109 | (when-let (text (message-text msg)) |
| 115 | (on-text-message bot msg text)) | 110 | (on-text-message msg text)) |
| 116 | 111 | ||
| 117 | (when-let (new-chat-members (message-new-chat-members msg)) | 112 | (when-let (new-chat-members (message-new-chat-members msg)) |
| 118 | (iter | 113 | (iter |
| 119 | (for new-chat-member in-vector new-chat-members) | 114 | (for new-chat-member in-vector new-chat-members) |
| 120 | (on-new-member bot msg new-chat-member))))) | 115 | (on-new-member msg new-chat-member))))) |
| 121 | 116 | ||
| 122 | (defun on-new-member (bot msg new-member) | 117 | (defun on-new-member (msg new-member) |
| 123 | (if (= (user-id new-member) (bot-id bot)) | 118 | (if (= (user-id new-member) (bot-id)) |
| 124 | (reply-animation bot msg #P"blob/rule-11.mp4" | 119 | (reply-animation msg #P"blob/rule-11.mp4" |
| 125 | :allow-sending-without-reply t) | 120 | :allow-sending-without-reply t) |
| 126 | (reply-animation bot msg #P"blob/rule-10.mp4" | 121 | (reply-animation msg #P"blob/rule-10.mp4" |
| 127 | :text (concatenate 'string "Hello there, " | 122 | :text (concatenate 'string "Hello there, " |
| 128 | (user-format-name new-member) | 123 | (user-format-name new-member) |
| 129 | "! Be on your bestest behaviour now!!") | 124 | "! Be on your bestest behaviour now!!") |
| @@ -136,7 +131,7 @@ | |||
| 136 | ;; TODO: | 131 | ;; TODO: |
| 137 | nil) | 132 | nil) |
| 138 | 133 | ||
| 139 | (defun on-text-message (bot msg text) | 134 | (defun on-text-message (msg text) |
| 140 | (block nil | 135 | (block nil |
| 141 | (when (is-bad-text text) | 136 | (when (is-bad-text text) |
| 142 | ;; TODO: Delete message, mute & warn user | 137 | ;; TODO: Delete message, mute & warn user |
| @@ -155,19 +150,19 @@ | |||
| 155 | (for entity in-vector entities) | 150 | (for entity in-vector entities) |
| 156 | (when (and (eql (message-entity-type entity) bot-command) | 151 | (when (and (eql (message-entity-type entity) bot-command) |
| 157 | (zerop (message-entity-offset entity))) | 152 | (zerop (message-entity-offset entity))) |
| 158 | (on-text-command bot msg text (message-entity-extract entity text))))) | 153 | (on-text-command msg text (message-entity-extract entity text))))) |
| 159 | 154 | ||
| 160 | ;; TODO: Replace this cond with a nicer dispatch. Something like string-case? | 155 | ;; TODO: Replace this cond with a nicer dispatch. Something like string-case? |
| 161 | (cond ((equal text ":3") | 156 | (cond ((equal text ":3") |
| 162 | (reply-message bot msg ">:3")) | 157 | (reply-message msg ">:3")) |
| 163 | 158 | ||
| 164 | ((equal text ">:3") | 159 | ((equal text ">:3") |
| 165 | (reply-message bot msg "<b>>:3</b>" :parse-mode html)) | 160 | (reply-message msg "<b>>:3</b>" :parse-mode html)) |
| 166 | 161 | ||
| 167 | ((str:starts-with-p "big " text) | 162 | ((str:starts-with-p "big " text) |
| 168 | (let ((the-text (drop 4 text))) | 163 | (let ((the-text (drop 4 text))) |
| 169 | (unless (is-tg-whitespace-str the-text) | 164 | (unless (is-tg-whitespace-str the-text) |
| 170 | (reply-message bot msg | 165 | (reply-message msg |
| 171 | (concatenate 'string | 166 | (concatenate 'string |
| 172 | "<b>" | 167 | "<b>" |
| 173 | (escape-xml (string-upcase the-text)) | 168 | (escape-xml (string-upcase the-text)) |
| @@ -175,33 +170,31 @@ | |||
| 175 | :parse-mode html)))) | 170 | :parse-mode html)))) |
| 176 | 171 | ||
| 177 | ((string-equal text "dio cane") | 172 | ((string-equal text "dio cane") |
| 178 | (reply-message bot | 173 | (reply-message (or (message-reply-to-message msg) msg) |
| 179 | (or (message-reply-to-message msg) msg) | ||
| 180 | "porco dio")) | 174 | "porco dio")) |
| 181 | 175 | ||
| 182 | ((string-equal text "forgor") | 176 | ((string-equal text "forgor") |
| 183 | (reply-message bot msg "💀")) | 177 | (reply-message msg "💀")) |
| 184 | 178 | ||
| 185 | ((string-equal text "huh") | 179 | ((string-equal text "huh") |
| 186 | (reply-message bot msg "idgi")) | 180 | (reply-message msg "idgi")) |
| 187 | 181 | ||
| 188 | ((string= text "H") | 182 | ((string= text "H") |
| 189 | (reply-message bot msg "<code>Randomly selected reminder that h > H.</code>" :parse-mode html)) | 183 | (reply-message msg "<code>Randomly selected reminder that h > H.</code>" :parse-mode html)) |
| 190 | 184 | ||
| 191 | ((string-equal text "porco dio") | 185 | ((string-equal text "porco dio") |
| 192 | (reply-message bot | 186 | (reply-message (or (message-reply-to-message msg) msg) |
| 193 | (or (message-reply-to-message msg) msg) | ||
| 194 | "dio cane")) | 187 | "dio cane")) |
| 195 | 188 | ||
| 196 | ((str:starts-with-p "say " text) | 189 | ((str:starts-with-p "say " text) |
| 197 | (let ((the-text (drop 4 text))) | 190 | (let ((the-text (drop 4 text))) |
| 198 | (unless (is-tg-whitespace-str the-text) | 191 | (unless (is-tg-whitespace-str the-text) |
| 199 | (reply-message bot msg the-text)))) | 192 | (reply-message msg the-text)))) |
| 200 | 193 | ||
| 201 | ((str:starts-with-p "tiny " text) | 194 | ((str:starts-with-p "tiny " text) |
| 202 | (let ((the-text (drop 5 text))) | 195 | (let ((the-text (drop 5 text))) |
| 203 | (unless (is-tg-whitespace-str the-text) | 196 | (unless (is-tg-whitespace-str the-text) |
| 204 | (reply-message bot msg | 197 | (reply-message msg |
| 205 | (map 'string #'(lambda (ch) | 198 | (map 'string #'(lambda (ch) |
| 206 | (if (is-tg-whitespace ch) | 199 | (if (is-tg-whitespace ch) |
| 207 | ch | 200 | ch |
| @@ -209,16 +202,15 @@ | |||
| 209 | the-text))))) | 202 | the-text))))) |
| 210 | 203 | ||
| 211 | ((string-equal text "uwu") | 204 | ((string-equal text "uwu") |
| 212 | (reply-message bot msg "OwO")) | 205 | (reply-message msg "OwO")) |
| 213 | 206 | ||
| 214 | ((string-equal text "waow") | 207 | ((string-equal text "waow") |
| 215 | (reply-message | 208 | (reply-message |
| 216 | bot | ||
| 217 | (or (message-reply-to-message msg) msg) | 209 | (or (message-reply-to-message msg) msg) |
| 218 | "BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED")) | 210 | "BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED")) |
| 219 | 211 | ||
| 220 | ((string-equal text "what") | 212 | ((string-equal text "what") |
| 221 | (reply-message bot msg | 213 | (reply-message msg |
| 222 | (with-output-to-string (s) | 214 | (with-output-to-string (s) |
| 223 | (if (char= (elt text 0) #\w) | 215 | (if (char= (elt text 0) #\w) |
| 224 | (write-char #\g s) | 216 | (write-char #\g s) |
| @@ -235,55 +227,53 @@ | |||
| 235 | 227 | ||
| 236 | (t nil)))) | 228 | (t nil)))) |
| 237 | 229 | ||
| 238 | (defun simplify-cmd (bot cmd) | 230 | (defun simplify-cmd (cmd) |
| 239 | (let ((at-idx (position #\@ cmd))) | 231 | (let ((at-idx (position #\@ cmd))) |
| 240 | (if (null at-idx) | 232 | (if (null at-idx) |
| 241 | (drop 1 cmd) | 233 | (drop 1 cmd) |
| 242 | (let ((username (drop (1+ at-idx) cmd)) | 234 | (let ((username (drop (1+ at-idx) cmd)) |
| 243 | (my-username (bot-username bot))) | 235 | (my-username (bot-username))) |
| 244 | (if (equal username my-username) | 236 | (if (equal username my-username) |
| 245 | (subseq cmd 1 at-idx) | 237 | (subseq cmd 1 at-idx) |
| 246 | nil))))) | 238 | nil))))) |
| 247 | 239 | ||
| 248 | (defun on-text-command (bot msg text cmd) | 240 | (defun on-text-command (msg text cmd) |
| 249 | (declare (ignore text)) | 241 | (declare (ignore text)) |
| 250 | (let ((simple-cmd (simplify-cmd bot cmd))) | 242 | (let ((simple-cmd (simplify-cmd cmd))) |
| 251 | (log:debug "text-command: ~A AKA ~A" cmd simple-cmd) | 243 | (log:debug "text-command: ~A AKA ~A" cmd simple-cmd) |
| 252 | ;; TODO: Replace this cond with a nicer dispatch. Something like string-case? | 244 | ;; TODO: Replace this cond with a nicer dispatch. Something like string-case? |
| 253 | (cond | 245 | (cond |
| 254 | ((equal simple-cmd "chatid") | 246 | ((equal simple-cmd "chatid") |
| 255 | (reply-message bot msg | 247 | (reply-message msg |
| 256 | #f"<code>{(message-chat-id msg)}</code>" | 248 | #f"<code>{(message-chat-id msg)}</code>" |
| 257 | :parse-mode html)) | 249 | :parse-mode html)) |
| 258 | 250 | ||
| 259 | ((equal simple-cmd "msginfo") | 251 | ((equal simple-cmd "msginfo") |
| 260 | (when-let (replied (message-reply-to-message msg)) | 252 | (when-let (replied (message-reply-to-message msg)) |
| 261 | (reply-message bot replied (let ((*print-pretty* t)) (fixup-value replied))))) | 253 | (reply-message replied (let ((*print-pretty* t)) (fixup-value replied))))) |
| 262 | 254 | ||
| 263 | ((equal simple-cmd "ping") | 255 | ((equal simple-cmd "ping") |
| 264 | (let* ((start-time (get-internal-real-time)) | 256 | (let* ((start-time (get-internal-real-time)) |
| 265 | (reply (reply-message bot msg #f"Pong!{;~2%}Send time: ...")) | 257 | (reply (reply-message msg #f"Pong!{;~2%}Send time: ...")) |
| 266 | (end-time (get-internal-real-time)) | 258 | (end-time (get-internal-real-time)) |
| 267 | (time-elapsed (* (/ (- end-time start-time) internal-time-units-per-second) | 259 | (time-elapsed (* (/ (- end-time start-time) internal-time-units-per-second) |
| 268 | 1000))) | 260 | 1000))) |
| 269 | (edit-message-text bot | 261 | (edit-message-text :chat-id (message-chat-id reply) |
| 270 | :chat-id (message-chat-id reply) | ||
| 271 | :message-id (message-id reply) | 262 | :message-id (message-id reply) |
| 272 | :text #f"Pong!{;~2%}Send time: {time-elapsed;~G}ms"))) | 263 | :text #f"Pong!{;~2%}Send time: {time-elapsed;~G}ms"))) |
| 273 | 264 | ||
| 274 | ((and (equal simple-cmd "shutdown") | 265 | ((and (equal simple-cmd "shutdown") |
| 275 | (message-from msg) | 266 | (message-from msg) |
| 276 | (= (user-id (message-from msg)) (conf:owner))) | 267 | (= (user-id (message-from msg)) (conf:owner))) |
| 277 | (setf (bot-power-on bot) nil) | 268 | (setf (state:power-on) nil) |
| 278 | (reply-message bot msg "Initialising shutdown..." :allow-sending-without-reply t))))) | 269 | (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t))))) |
| 279 | 270 | ||
| 280 | (defun escape-xml-obj (obj) | 271 | (defun escape-xml-obj (obj) |
| 281 | (escape-xml #f"{obj}")) | 272 | (escape-xml #f"{obj}")) |
| 282 | 273 | ||
| 283 | (defun report-error (bot evt err) | 274 | (defun report-error (evt err) |
| 284 | (log:error "While handling ~A: ~A" evt err) | 275 | (log:error "While handling ~A: ~A" evt err) |
| 285 | (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>")) | 276 | (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>")) |
| 286 | (send-message bot | 277 | (send-message :chat-id (conf:dev-group) |
| 287 | :chat-id (conf:dev-group) | 278 | :text msg |
| 288 | :text msg | 279 | :parse-mode html))) |
| 289 | :parse-mode html))) | ||
diff --git a/src/state.lisp b/src/state.lisp index 6348ee3..ef4050d 100644 --- a/src/state.lisp +++ b/src/state.lisp | |||
| @@ -2,30 +2,95 @@ | |||
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/src/state | 3 | (defpackage :ukkoclot/src/state |
| 4 | (:documentation "Holds the global state") | 4 | (:documentation "Holds the global state") |
| 5 | (:use :c2cl) | 5 | (:nicknames :state) |
| 6 | (:use :c2cl :ukkoclot/src/rw-lock) | ||
| 6 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 7 | (:import-from :conf :bot-token) | 8 | (:import-from :conf :*config* :bot-token) |
| 9 | (:import-from :sqlite :sqlite-handle) | ||
| 8 | (:export | 10 | (:export |
| 9 | #:bot | 11 | #:*state* |
| 10 | #:make-bot | 12 | #:state |
| 11 | #:bot-p | 13 | #:make-state |
| 12 | #:copy-bot | 14 | #:state-p |
| 13 | #:bot-db | 15 | #:db |
| 14 | #:bot-base-uri | 16 | #:base-uri |
| 15 | #:bot-power-on | 17 | #:power-on |
| 16 | #:bot-username% | 18 | #:set-power-on |
| 17 | #:bot-id%)) | 19 | #:username% |
| 20 | #:set-username% | ||
| 21 | #:id% | ||
| 22 | #:set-id%)) | ||
| 18 | (in-package :ukkoclot/src/state) | 23 | (in-package :ukkoclot/src/state) |
| 19 | 24 | ||
| 20 | (enable-f-strings) | 25 | (enable-f-strings) |
| 21 | 26 | ||
| 22 | (defstruct (bot (:constructor make-bot%)) | 27 | (defstruct (state (:constructor make-state%)) |
| 23 | (db (error "No value given for DB") :read-only t) | 28 | (lock (make-rw-lock :name "state's lock") :type rw-lock :read-only t) |
| 24 | (base-uri (error "No value given for base-uri") :read-only t) | 29 | (db (error "No value given for DB") :type sqlite-handle :read-only t) |
| 30 | (base-uri (error "No value given for base-uri") :type string :read-only t) | ||
| 25 | (power-on t :type boolean) | 31 | (power-on t :type boolean) |
| 26 | (username% nil :type (or string null)) | 32 | (username% nil :type (or string null)) |
| 27 | (id% nil :type (or integer null))) | 33 | (id% nil :type (or integer null))) |
| 28 | 34 | ||
| 29 | (defun make-bot (db) | 35 | (defun make-state (db &optional (config *config*)) |
| 30 | (let ((base-uri #f"https://api.telegram.org/bot{(bot-token)}/")) | 36 | (check-type db sqlite-handle) |
| 31 | (make-bot% :db db :base-uri base-uri))) | 37 | (let ((base-uri #f"https://api.telegram.org/bot{(bot-token config)}/")) |
| 38 | (make-state% :db db :base-uri base-uri))) | ||
| 39 | |||
| 40 | (defvar *state* nil | ||
| 41 | "Bot's general state. You should initialise this with a value before doing anything fun.") | ||
| 42 | |||
| 43 | (defun db (&optional (state *state*)) | ||
| 44 | "Get the database handle of the bot." | ||
| 45 | (with-slots (lock db) state | ||
| 46 | (with-read-lock (lock) | ||
| 47 | db))) | ||
| 48 | |||
| 49 | (defun base-uri (&optional (state *state*)) | ||
| 50 | "Get the base URI of the bot." | ||
| 51 | (with-slots (lock base-uri) state | ||
| 52 | (with-read-lock (lock) | ||
| 53 | base-uri))) | ||
| 54 | |||
| 55 | (defun power-on (&optional (state *state*)) | ||
| 56 | "Get whether the bot is running" | ||
| 57 | (with-slots (lock power-on) state | ||
| 58 | (with-read-lock (lock) | ||
| 59 | power-on))) | ||
| 60 | |||
| 61 | (defun set-power-on (new-value &optional (state *state*)) | ||
| 62 | "Set the value of the power-on" | ||
| 63 | (with-slots (lock power-on) state | ||
| 64 | (with-write-lock (lock) | ||
| 65 | (setf power-on new-value)))) | ||
| 66 | |||
| 67 | (defsetf power-on (&optional (state '*state*)) (new-value) | ||
| 68 | `(set-power-on ,new-value ,state)) | ||
| 69 | |||
| 70 | (defun username% (&optional (state *state*)) | ||
| 71 | "Get the cached bot's username, you should probably use `ukkoclot/src/tg:bot-username' instead." | ||
| 72 | (with-slots (lock username%) state | ||
| 73 | (with-read-lock (lock) | ||
| 74 | username%))) | ||
| 75 | |||
| 76 | (defun set-username% (new-value &optional (state *state*)) | ||
| 77 | (with-slots (lock username%) state | ||
| 78 | (with-write-lock (lock) | ||
| 79 | (setf username% new-value)))) | ||
| 80 | |||
| 81 | (defsetf username% (&optional (state '*state*)) (new-value) | ||
| 82 | `(set-username% ,new-value ,state)) | ||
| 83 | |||
| 84 | (defun id% (&optional (state *state*)) | ||
| 85 | "Get the cached bot's ID, you should probably use `ukkoclot/src/tg:bot-id' instead." | ||
| 86 | (with-slots (lock id%) state | ||
| 87 | (with-read-lock (lock) | ||
| 88 | id%))) | ||
| 89 | |||
| 90 | (defun set-id% (new-value &optional (state *state*)) | ||
| 91 | (with-slots (lock id%) state | ||
| 92 | (with-write-lock (lock) | ||
| 93 | (setf id% new-value)))) | ||
| 94 | |||
| 95 | (defsetf id% (&optional (state '*state*)) (new-value) | ||
| 96 | `(set-id% ,new-value ,state)) | ||
diff --git a/src/tg/delete-message.lisp b/src/tg/delete-message.lisp index cc52371..2b332df 100644 --- a/src/tg/delete-message.lisp +++ b/src/tg/delete-message.lisp | |||
| @@ -1,6 +1,7 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/src/tg/delete-message | 3 | (defpackage :ukkoclot/src/tg/delete-message |
| 4 | (:documentation "deleteMessage Telegram method") | ||
| 4 | (:use :c2cl :ukkoclot/src/tg/message :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/send-animation) | 5 | (:use :c2cl :ukkoclot/src/tg/message :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/send-animation) |
| 5 | (:export :delete-message :try-delete-message)) | 6 | (:export :delete-message :try-delete-message)) |
| 6 | (in-package :ukkoclot/src/tg/delete-message) | 7 | (in-package :ukkoclot/src/tg/delete-message) |
| @@ -9,13 +10,13 @@ | |||
| 9 | (chat-id (or integer string)) | 10 | (chat-id (or integer string)) |
| 10 | (message-id integer)) | 11 | (message-id integer)) |
| 11 | 12 | ||
| 12 | (defun try-delete-message (bot msg) | 13 | (defun try-delete-message (msg) |
| 14 | "Attempt to delete the MSG, on failure reply with a GIF of the DO NOT cat." | ||
| 13 | (handler-case | 15 | (handler-case |
| 14 | (delete-message bot | 16 | (delete-message :chat-id (message-chat-id msg) |
| 15 | :chat-id (message-chat-id msg) | ||
| 16 | :message-id (message-id msg)) | 17 | :message-id (message-id msg)) |
| 17 | (error () | 18 | (error () |
| 18 | (handler-case | 19 | (handler-case |
| 19 | (reply-animation bot msg #P"blob/do-not.mp4" | 20 | (reply-animation msg #P"blob/do-not.mp4" |
| 20 | :allow-sending-without-reply nil) | 21 | :allow-sending-without-reply nil) |
| 21 | (error () nil))))) | 22 | (error () nil))))) |
diff --git a/src/tg/get-me.lisp b/src/tg/get-me.lisp index b7e8bc0..e7d41a1 100644 --- a/src/tg/get-me.lisp +++ b/src/tg/get-me.lisp | |||
| @@ -1,27 +1,31 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/src/tg/get-me | 3 | (defpackage :ukkoclot/src/tg/get-me |
| 4 | (:documentation "getMe Telegram method") | ||
| 4 | (:use :c2cl :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/user) | 5 | (:use :c2cl :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/user) |
| 5 | (:import-from :ukkoclot/src/state :bot-id% :bot-username%) | 6 | (:import-from :state) |
| 6 | (:export :bot-id :bot-username :get-me)) | 7 | (:export :bot-id :bot-username :get-me)) |
| 7 | (in-package :ukkoclot/src/tg/get-me) | 8 | (in-package :ukkoclot/src/tg/get-me) |
| 8 | 9 | ||
| 9 | (define-tg-method (get-me% user :GET)) | 10 | (define-tg-method (get-me% user :GET)) |
| 10 | 11 | ||
| 11 | (defun get-me (bot) | 12 | (defun get-me () |
| 12 | (let ((me (get-me% bot))) | 13 | "getMe Telegram method" |
| 13 | (setf (bot-id% bot) (user-id me)) | 14 | (let ((me (get-me%))) |
| 14 | (setf (bot-username% bot) (user-username me)) | 15 | (setf (state:id%) (user-id me)) |
| 16 | (setf (state:username%) (user-username me)) | ||
| 15 | me)) | 17 | me)) |
| 16 | 18 | ||
| 17 | (defun bot-id (bot) | 19 | (defun bot-id () |
| 18 | (or (bot-id% bot) | 20 | "Get the bot's ID, this memoizes the result" |
| 21 | (or (state:id%) | ||
| 19 | (progn | 22 | (progn |
| 20 | (get-me bot) | 23 | (get-me) |
| 21 | (bot-id% bot)))) | 24 | (state:id%)))) |
| 22 | 25 | ||
| 23 | (defun bot-username (bot) | 26 | (defun bot-username () |
| 24 | (or (bot-username% bot) | 27 | "Get the bot's username, this memoizes the result" |
| 28 | (or (state:username%) | ||
| 25 | (progn | 29 | (progn |
| 26 | (get-me bot) | 30 | (get-me) |
| 27 | (bot-username% bot)))) | 31 | (state:username%)))) |
diff --git a/src/tg/method-macros.lisp b/src/tg/method-macros.lisp index 00adf95..56445e3 100644 --- a/src/tg/method-macros.lisp +++ b/src/tg/method-macros.lisp | |||
| @@ -6,8 +6,8 @@ | |||
| 6 | (:import-from :alexandria :with-gensyms) | 6 | (:import-from :alexandria :with-gensyms) |
| 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 8 | (:import-from :serapeum :take) | 8 | (:import-from :serapeum :take) |
| 9 | (:import-from :state) | ||
| 9 | (:import-from :str) | 10 | (:import-from :str) |
| 10 | (:import-from :ukkoclot/src/state :bot) | ||
| 11 | (:import-from :ukkoclot/src/transport :do-call) | 11 | (:import-from :ukkoclot/src/transport :do-call) |
| 12 | (:export :define-tg-method)) | 12 | (:export :define-tg-method)) |
| 13 | (in-package :ukkoclot/src/tg/method-macros) | 13 | (in-package :ukkoclot/src/tg/method-macros) |
| @@ -53,9 +53,9 @@ | |||
| 53 | `(,(param-name param) ,(param-default param))) | 53 | `(,(param-name param) ,(param-default param))) |
| 54 | 54 | ||
| 55 | (defun emit-defun (name return-type params method) | 55 | (defun emit-defun (name return-type params method) |
| 56 | (with-gensyms (args bot) | 56 | (with-gensyms (args) |
| 57 | `(defun ,name (,bot &key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid | 57 | `(defun ,name (&key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid |
| 58 | (collect (emit-defun-arg param)))) | 58 | (collect (emit-defun-arg param)))) |
| 59 | (let (,args) | 59 | (let (,args) |
| 60 | ,@(iter (for param in (reverse params)) | 60 | ,@(iter (for param in (reverse params)) |
| 61 | (collect (if (param-skip-if-default param) | 61 | (collect (if (param-skip-if-default param) |
| @@ -63,11 +63,11 @@ | |||
| 63 | ,(param-default param)) | 63 | ,(param-default param)) |
| 64 | ,(emit-append-to-args param args)) | 64 | ,(emit-append-to-args param args)) |
| 65 | (emit-append-to-args param args)))) | 65 | (emit-append-to-args param args)))) |
| 66 | (do-call ,bot ,method ,(path-from-name name) ',return-type ,args))))) | 66 | (do-call ,method ,(path-from-name name) ',return-type ,args))))) |
| 67 | 67 | ||
| 68 | (defun emit-ftype (name return-type params) | 68 | (defun emit-ftype (name return-type params) |
| 69 | `(declaim (ftype (function (bot &key ,@(iter (for param in params) | 69 | `(declaim (ftype (function (&key ,@(iter (for param in params) |
| 70 | (collect (emit-arg-type param)))) | 70 | (collect (emit-arg-type param)))) |
| 71 | ,return-type) | 71 | ,return-type) |
| 72 | ,name)))) | 72 | ,name)))) |
| 73 | 73 | ||
diff --git a/src/tg/send-animation.lisp b/src/tg/send-animation.lisp index a0b2d57..560b331 100644 --- a/src/tg/send-animation.lisp +++ b/src/tg/send-animation.lisp | |||
| @@ -1,6 +1,7 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/src/tg/send-animation | 3 | (defpackage :ukkoclot/src/tg/send-animation |
| 4 | (:documentation "sendAnimation Telegram method") | ||
| 4 | (:use | 5 | (:use |
| 5 | :c2cl | 6 | :c2cl |
| 6 | :ukkoclot/src/tg/force-reply | 7 | :ukkoclot/src/tg/force-reply |
| @@ -40,9 +41,9 @@ | |||
| 40 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) | 41 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) |
| 41 | 42 | ||
| 42 | ;; TODO: Some kind of caching for files? | 43 | ;; TODO: Some kind of caching for files? |
| 43 | (defun reply-animation (bot msg animation &key allow-sending-without-reply text parse-mode caption-above) | 44 | (defun reply-animation (msg animation &key allow-sending-without-reply text parse-mode caption-above) |
| 44 | (send-animation bot | 45 | "Shortcut to reply to a given MSG with an animation." |
| 45 | :chat-id (message-chat-id msg) | 46 | (send-animation :chat-id (message-chat-id msg) |
| 46 | :animation animation | 47 | :animation animation |
| 47 | :caption text | 48 | :caption text |
| 48 | :parse-mode parse-mode | 49 | :parse-mode parse-mode |
diff --git a/src/tg/send-message.lisp b/src/tg/send-message.lisp index 9edc50d..befecbe 100644 --- a/src/tg/send-message.lisp +++ b/src/tg/send-message.lisp | |||
| @@ -1,6 +1,7 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/src/tg/send-message | 3 | (defpackage :ukkoclot/src/tg/send-message |
| 4 | (:documentation "sendMessage Telegram method") | ||
| 4 | (:use | 5 | (:use |
| 5 | :c2cl | 6 | :c2cl |
| 6 | :ukkoclot/src/tg/force-reply | 7 | :ukkoclot/src/tg/force-reply |
| @@ -30,9 +31,9 @@ | |||
| 30 | (reply-parameters (or reply-parameters null) nil) | 31 | (reply-parameters (or reply-parameters null) nil) |
| 31 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) | 32 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) |
| 32 | 33 | ||
| 33 | (defun reply-message (bot msg text &key parse-mode allow-sending-without-reply) | 34 | (defun reply-message (msg text &key parse-mode allow-sending-without-reply) |
| 34 | (send-message bot | 35 | "Shortcut to reply to a given MSG." |
| 35 | :chat-id (message-chat-id msg) | 36 | (send-message :chat-id (message-chat-id msg) |
| 36 | :text text | 37 | :text text |
| 37 | :parse-mode parse-mode | 38 | :parse-mode parse-mode |
| 38 | :reply-parameters | 39 | :reply-parameters |
diff --git a/src/tg/set-my-name.lisp b/src/tg/set-my-name.lisp index 67c698d..2b3869a 100644 --- a/src/tg/set-my-name.lisp +++ b/src/tg/set-my-name.lisp | |||
| @@ -1,6 +1,7 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/src/tg/set-my-name | 3 | (defpackage :ukkoclot/src/tg/set-my-name |
| 4 | (:documentation "setMyName Telegram method.") | ||
| 4 | (:use :c2cl :ukkoclot/src/tg/bot-name :ukkoclot/src/tg/get-my-name :ukkoclot/src/tg/method-macros) | 5 | (:use :c2cl :ukkoclot/src/tg/bot-name :ukkoclot/src/tg/get-my-name :ukkoclot/src/tg/method-macros) |
| 5 | (:export :set-my-name)) | 6 | (:export :set-my-name)) |
| 6 | (in-package :ukkoclot/src/tg/set-my-name) | 7 | (in-package :ukkoclot/src/tg/set-my-name) |
| @@ -9,11 +10,14 @@ | |||
| 9 | (name (or string null) nil) | 10 | (name (or string null) nil) |
| 10 | (language-code (or string null) nil)) | 11 | (language-code (or string null) nil)) |
| 11 | 12 | ||
| 12 | (defun set-my-name (bot &key (name nil) (language-code nil)) | 13 | (defun set-my-name (&key (name nil) (language-code nil)) |
| 14 | "setMyName Telegram method. | ||
| 15 | |||
| 16 | We also first check if the name is already set because setMyName has a very heavy rate limiting impact." | ||
| 13 | (block nil | 17 | (block nil |
| 14 | (when name | 18 | (when name |
| 15 | (let ((curr-name (get-my-name bot :language-code language-code))) | 19 | (let ((curr-name (get-my-name :language-code language-code))) |
| 16 | (when (string= name (bot-name-name curr-name)) | 20 | (when (string= name (bot-name-name curr-name)) |
| 17 | (return)))) | 21 | (return)))) |
| 18 | (unless (set-my-name% bot :name name :language-code language-code) | 22 | (unless (set-my-name% :name name :language-code language-code) |
| 19 | (error "Failed to set name")))) | 23 | (error "Failed to set name")))) |
diff --git a/src/transport.lisp b/src/transport.lisp index bb451c1..6906e6d 100644 --- a/src/transport.lisp +++ b/src/transport.lisp | |||
| @@ -6,8 +6,8 @@ | |||
| 6 | (:import-from :cl+ssl) | 6 | (:import-from :cl+ssl) |
| 7 | (:import-from :dex) | 7 | (:import-from :dex) |
| 8 | (:import-from :log) | 8 | (:import-from :log) |
| 9 | (:import-from :state :base-uri) | ||
| 9 | (:import-from :ukkoclot/src/serializing :fixup-args :parse-value) | 10 | (:import-from :ukkoclot/src/serializing :fixup-args :parse-value) |
| 10 | (:import-from :ukkoclot/src/state :bot-base-uri) | ||
| 11 | (:local-nicknames | 11 | (:local-nicknames |
| 12 | (:jzon :com.inuoe.jzon)) | 12 | (:jzon :com.inuoe.jzon)) |
| 13 | (:export :do-call)) | 13 | (:export :do-call)) |
| @@ -47,9 +47,9 @@ See `do-call'." | |||
| 47 | (error "TG error ~A: ~A ~:A" | 47 | (error "TG error ~A: ~A ~:A" |
| 48 | error-code description parameters))))))) | 48 | error-code description parameters))))))) |
| 49 | 49 | ||
| 50 | (defun do-call (bot method path out-type args) | 50 | (defun do-call (method path out-type args) |
| 51 | "Perform a HTTP call." | 51 | "Perform a HTTP call." |
| 52 | (let ((uri (concatenate 'string (bot-base-uri bot) path)) | 52 | (let ((uri (concatenate 'string (base-uri) path)) |
| 53 | (args-encoded (fixup-args args))) | 53 | (args-encoded (fixup-args args))) |
| 54 | (log:debug "~A .../~A ~S" method path args-encoded) | 54 | (log:debug "~A .../~A ~S" method path args-encoded) |
| 55 | (do-call% method uri out-type args-encoded))) | 55 | (do-call% method uri out-type args-encoded))) |
diff --git a/ukkoclot.asd b/ukkoclot.asd index 339a208..806c632 100644 --- a/ukkoclot.asd +++ b/ukkoclot.asd | |||
| @@ -16,6 +16,7 @@ | |||
| 16 | 16 | ||
| 17 | (register-system-packages :ukkoclot/src/config '(:conf)) | 17 | (register-system-packages :ukkoclot/src/config '(:conf)) |
| 18 | (register-system-packages :ukkoclot/src/main '(:ukkoclot)) | 18 | (register-system-packages :ukkoclot/src/main '(:ukkoclot)) |
| 19 | (register-system-packages :ukkoclot/src/state '(:state)) | ||
| 19 | 20 | ||
| 20 | (register-system-packages :bordeaux-threads '(:bt2)) | 21 | (register-system-packages :bordeaux-threads '(:bt2)) |
| 21 | (register-system-packages :closer-mop '(:c2cl)) | 22 | (register-system-packages :closer-mop '(:c2cl)) |