diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/config.lisp | 14 | ||||
| -rw-r--r-- | src/db.lisp | 34 | ||||
| -rw-r--r-- | src/enum.lisp | 13 | ||||
| -rw-r--r-- | src/inline-bots.lisp | 12 | ||||
| -rw-r--r-- | src/main.lisp | 41 | ||||
| -rw-r--r-- | src/rw-lock.lisp | 11 | ||||
| -rw-r--r-- | src/serializing.lisp | 6 | ||||
| -rw-r--r-- | src/state.lisp | 19 | ||||
| -rw-r--r-- | src/strings.lisp | 36 | ||||
| -rw-r--r-- | src/tg/delete-message.lisp | 7 | ||||
| -rw-r--r-- | src/tg/get-me.lisp | 4 | ||||
| -rw-r--r-- | src/tg/message-entity.lisp | 3 | ||||
| -rw-r--r-- | src/tg/message.lisp | 13 | ||||
| -rw-r--r-- | src/tg/method-macros.lisp | 23 | ||||
| -rw-r--r-- | src/tg/send-animation.lisp | 9 | ||||
| -rw-r--r-- | src/tg/send-message.lisp | 6 | ||||
| -rw-r--r-- | src/tg/set-my-name.lisp | 4 | ||||
| -rw-r--r-- | src/tg/type-macros.lisp | 28 | ||||
| -rw-r--r-- | src/tg/user.lisp | 37 | ||||
| -rw-r--r-- | src/transport.lisp | 13 |
20 files changed, 238 insertions, 95 deletions
diff --git a/src/config.lisp b/src/config.lisp index 85c9662..7117de3 100644 --- a/src/config.lisp +++ b/src/config.lisp | |||
| @@ -5,6 +5,7 @@ | |||
| 5 | (:nicknames :conf) | 5 | (:nicknames :conf) |
| 6 | (:use :c2cl :iterate :ukkoclot/src/rw-lock) | 6 | (:use :c2cl :iterate :ukkoclot/src/rw-lock) |
| 7 | (:import-from :alexandria :make-keyword) | 7 | (:import-from :alexandria :make-keyword) |
| 8 | (:import-from :serapeum :->) | ||
| 8 | (:export | 9 | (:export |
| 9 | #:*config* | 10 | #:*config* |
| 10 | #:config | 11 | #:config |
| @@ -31,36 +32,42 @@ | |||
| 31 | (defvar *config* (make-config) | 32 | (defvar *config* (make-config) |
| 32 | "Bot's configuration") | 33 | "Bot's configuration") |
| 33 | 34 | ||
| 35 | (-> bot-name (&optional config) string) | ||
| 34 | (defun bot-name (&optional (config *config*)) | 36 | (defun bot-name (&optional (config *config*)) |
| 35 | "Get the desired name for the bot" | 37 | "Get the desired name for the bot" |
| 36 | (with-slots (lock bot-name) config | 38 | (with-slots (lock bot-name) config |
| 37 | (with-read-lock (lock) | 39 | (with-read-lock (lock) |
| 38 | bot-name))) | 40 | bot-name))) |
| 39 | 41 | ||
| 42 | (-> bot-token (&optional config) string) | ||
| 40 | (defun bot-token (&optional (config *config*)) | 43 | (defun bot-token (&optional (config *config*)) |
| 41 | "Get the API token for the bot" | 44 | "Get the API token for the bot" |
| 42 | (with-slots (lock bot-token) config | 45 | (with-slots (lock bot-token) config |
| 43 | (with-read-lock (lock) | 46 | (with-read-lock (lock) |
| 44 | bot-token))) | 47 | bot-token))) |
| 45 | 48 | ||
| 49 | (-> db-path (&optional config) pathname) | ||
| 46 | (defun db-path (&optional (config *config*)) | 50 | (defun db-path (&optional (config *config*)) |
| 47 | "Get the path to the bot's database" | 51 | "Get the path to the bot's database" |
| 48 | (with-slots (lock db-path) config | 52 | (with-slots (lock db-path) config |
| 49 | (with-read-lock (lock) | 53 | (with-read-lock (lock) |
| 50 | db-path))) | 54 | (pathname db-path)))) |
| 51 | 55 | ||
| 56 | (-> dev-group (&optional config) integer) | ||
| 52 | (defun dev-group (&optional (config *config*)) | 57 | (defun dev-group (&optional (config *config*)) |
| 53 | "Get the ID of the dev/testing group" | 58 | "Get the ID of the dev/testing group" |
| 54 | (with-slots (lock dev-group) config | 59 | (with-slots (lock dev-group) config |
| 55 | (with-read-lock (lock) | 60 | (with-read-lock (lock) |
| 56 | dev-group))) | 61 | dev-group))) |
| 57 | 62 | ||
| 63 | (-> owner (&optional config) integer) | ||
| 58 | (defun owner (&optional (config *config*)) | 64 | (defun owner (&optional (config *config*)) |
| 59 | "Get the ID of the bot's owner" | 65 | "Get the ID of the bot's owner" |
| 60 | (with-slots (lock owner) config | 66 | (with-slots (lock owner) config |
| 61 | (with-read-lock (lock) | 67 | (with-read-lock (lock) |
| 62 | owner))) | 68 | owner))) |
| 63 | 69 | ||
| 70 | (-> load-config (pathname &optional config) config) | ||
| 64 | (defun load-config (filename &optional (config *config*)) | 71 | (defun load-config (filename &optional (config *config*)) |
| 65 | "Load config from the given `filename'." | 72 | "Load config from the given `filename'." |
| 66 | (prog1 config | 73 | (prog1 config |
| @@ -71,6 +78,7 @@ | |||
| 71 | (let ((name (intern (symbol-name kw-name) :ukkoclot/src/config))) | 78 | (let ((name (intern (symbol-name kw-name) :ukkoclot/src/config))) |
| 72 | (setf (slot-value config name) value))))))) | 79 | (setf (slot-value config name) value))))))) |
| 73 | 80 | ||
| 81 | (-> serialize (config) list) | ||
| 74 | (defun serialize (config) | 82 | (defun serialize (config) |
| 75 | "Serializes the config to a plist." | 83 | "Serializes the config to a plist." |
| 76 | (with-read-lock ((config-lock config)) | 84 | (with-read-lock ((config-lock config)) |
| @@ -81,10 +89,12 @@ | |||
| 81 | (appending (list (make-keyword name) | 89 | (appending (list (make-keyword name) |
| 82 | (slot-value config name)))))))) | 90 | (slot-value config name)))))))) |
| 83 | 91 | ||
| 92 | (-> print-default (pathname) (values &optional)) | ||
| 84 | (defun print-default (filename) | 93 | (defun print-default (filename) |
| 85 | "Prints the default config to the given `filename'." | 94 | "Prints the default config to the given `filename'." |
| 86 | (with-open-file (f filename :direction :output :if-exists :supersede) | 95 | (with-open-file (f filename :direction :output :if-exists :supersede) |
| 87 | (format f ";; lint:suppress in-package spdx-license-identifier~%") | 96 | (format f ";; lint:suppress in-package spdx-license-identifier~%") |
| 88 | (format f ";; Copy this file to config.lisp and modify it there~%") | 97 | (format f ";; Copy this file to config.lisp and modify it there~%") |
| 89 | (let ((data (serialize (make-config)))) | 98 | (let ((data (serialize (make-config)))) |
| 90 | (format f "~<(~;~@{~(~W~) ~W~^ ~_~}~;)~:>~%" data)))) | 99 | (format f "~<(~;~@{~(~W~) ~W~^ ~_~}~;)~:>~%" data))) |
| 100 | (values)) | ||
diff --git a/src/db.lisp b/src/db.lisp index 60b8115..ea18d16 100644 --- a/src/db.lisp +++ b/src/db.lisp | |||
| @@ -3,40 +3,51 @@ | |||
| 3 | (defpackage :ukkoclot/src/db | 3 | (defpackage :ukkoclot/src/db |
| 4 | (:use :c2cl :sqlite) | 4 | (:use :c2cl :sqlite) |
| 5 | (:import-from :log) | 5 | (:import-from :log) |
| 6 | (:export :get-inline-bot-type :set-inline-bot-type :with-db)) | 6 | (:import-from :serapeum :-> :defunion) |
| 7 | (:export :inline-bot-type :blacklisted :whitelisted :get-inline-bot-type :set-inline-bot-type :with-db)) | ||
| 7 | (in-package :ukkoclot/src/db) | 8 | (in-package :ukkoclot/src/db) |
| 8 | 9 | ||
| 9 | (defconstant +target-version+ 1 | 10 | (defconstant +target-version+ 1 |
| 10 | "Intended DB version") | 11 | "Intended DB version") |
| 11 | 12 | ||
| 13 | (deftype db () | ||
| 14 | 'sqlite-handle) | ||
| 15 | |||
| 12 | (defmacro with-db ((name path) &body body) | 16 | (defmacro with-db ((name path) &body body) |
| 13 | `(let ((,name (connect ,path))) | 17 | `(let ((,name (connect ,path))) |
| 14 | (unwind-protect (progn (upgrade ,name) ,@body) | 18 | (unwind-protect (progn (upgrade ,name) ,@body) |
| 15 | (disconnect ,name)))) | 19 | (disconnect ,name)))) |
| 16 | 20 | ||
| 21 | (defunion inline-bot-type | ||
| 22 | blacklisted | ||
| 23 | whitelisted) | ||
| 24 | |||
| 25 | (-> get-inline-bot-type (db integer) (or inline-bot-type null)) | ||
| 17 | (defun get-inline-bot-type (db id) | 26 | (defun get-inline-bot-type (db id) |
| 18 | (let ((type-int (execute-single db "SELECT type FROM inline_bots WHERE id = ?" id))) | 27 | (let ((type-int (execute-single db "SELECT type FROM inline_bots WHERE id = ?" id))) |
| 19 | (when type-int | 28 | (when type-int |
| 20 | (integer->inline-bot-type type-int)))) | 29 | (integer->inline-bot-type type-int)))) |
| 21 | 30 | ||
| 31 | (-> set-inline-bot-type (db integer inline-bot-type) (values &optional)) | ||
| 22 | (defun set-inline-bot-type (db id type) | 32 | (defun set-inline-bot-type (db id type) |
| 23 | (execute-non-query db | 33 | (execute-non-query db |
| 24 | "INSERT OR REPLACE INTO inline_bots (id, type) VALUES (?, ?)" | 34 | "INSERT OR REPLACE INTO inline_bots (id, type) VALUES (?, ?)" |
| 25 | id | 35 | id |
| 26 | (inline-bot-type->integer type))) | 36 | (inline-bot-type->integer type))) |
| 27 | 37 | ||
| 38 | (-> inline-bot-type->integer (inline-bot-type) integer) | ||
| 28 | (defun inline-bot-type->integer (type) | 39 | (defun inline-bot-type->integer (type) |
| 29 | (case type | 40 | (etypecase type |
| 30 | (:blacklisted 0) | 41 | (blacklisted 0) |
| 31 | (:whitelisted 1) | 42 | (whitelisted 1))) |
| 32 | (otherwise (error "Unknown inline bot type ~S" type)))) | ||
| 33 | 43 | ||
| 44 | (-> integer->inline-bot-type (integer) inline-bot-type) | ||
| 34 | (defun integer->inline-bot-type (num) | 45 | (defun integer->inline-bot-type (num) |
| 35 | (case num | 46 | (ecase num |
| 36 | (0 :blacklisted) | 47 | (0 blacklisted) |
| 37 | (1 :whitelisted) | 48 | (1 whitelisted))) |
| 38 | (otherwise (error "Unknown inline bot type value ~S" num)))) | ||
| 39 | 49 | ||
| 50 | (-> upgrade (db) (values &optional)) | ||
| 40 | (defun upgrade (db) | 51 | (defun upgrade (db) |
| 41 | (execute-non-query db "CREATE TABLE IF NOT EXISTS version(id INTEGER PRIMARY KEY, version INTEGER)") | 52 | (execute-non-query db "CREATE TABLE IF NOT EXISTS version(id INTEGER PRIMARY KEY, version INTEGER)") |
| 42 | (let ((current-ver (execute-single db "SELECT version FROM version WHERE id = 0"))) | 53 | (let ((current-ver (execute-single db "SELECT version FROM version WHERE id = 0"))) |
| @@ -62,6 +73,7 @@ | |||
| 62 | current-ver))) | 73 | current-ver))) |
| 63 | (log:info "Database updating complete :)"))))) | 74 | (log:info "Database updating complete :)"))))) |
| 64 | 75 | ||
| 76 | (-> upgrade-step (db integer) (values &optional)) | ||
| 65 | (defun upgrade-step (db new-version) | 77 | (defun upgrade-step (db new-version) |
| 66 | (case new-version | 78 | (case new-version |
| 67 | (1 | 79 | (1 |
| @@ -73,8 +85,8 @@ CREATE TABLE inline_bots_enum ( | |||
| 73 | (execute-non-query db " | 85 | (execute-non-query db " |
| 74 | INSERT INTO inline_bots_enum(id, value) | 86 | INSERT INTO inline_bots_enum(id, value) |
| 75 | VALUES (?, 'blacklisted'), (?, 'whitelisted')" | 87 | VALUES (?, 'blacklisted'), (?, 'whitelisted')" |
| 76 | (inline-bot-type->integer :blacklisted) | 88 | (inline-bot-type->integer blacklisted) |
| 77 | (inline-bot-type->integer :whitelisted)) | 89 | (inline-bot-type->integer whitelisted)) |
| 78 | 90 | ||
| 79 | (execute-non-query db "DROP TABLE IF EXISTS inline_bots") | 91 | (execute-non-query db "DROP TABLE IF EXISTS inline_bots") |
| 80 | (execute-non-query db " | 92 | (execute-non-query db " |
diff --git a/src/enum.lisp b/src/enum.lisp index b7cce15..3599174 100644 --- a/src/enum.lisp +++ b/src/enum.lisp | |||
| @@ -4,8 +4,9 @@ | |||
| 4 | (:documentation "Macro for generating an enum type.") | 4 | (:documentation "Macro for generating an enum type.") |
| 5 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :alexandria :with-gensyms) | 6 | (:import-from :alexandria :with-gensyms) |
| 7 | (:import-from :ukkoclot/src/serializing :fixup-value :parse-value) | 7 | (:import-from :serapeum :->) |
| 8 | (:import-from :string-case :string-case) | 8 | (:import-from :string-case :string-case) |
| 9 | (:import-from :ukkoclot/src/serializing :fixup-value :parse-value) | ||
| 9 | (:local-nicknames | 10 | (:local-nicknames |
| 10 | (:jzon :com.inuoe.jzon)) | 11 | (:jzon :com.inuoe.jzon)) |
| 11 | (:export :define-enum)) | 12 | (:export :define-enum)) |
| @@ -14,36 +15,46 @@ | |||
| 14 | (eval-when (:compile-toplevel :load-toplevel :execute) | 15 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 15 | (defstruct (field (:constructor make-field%)) name string) | 16 | (defstruct (field (:constructor make-field%)) name string) |
| 16 | 17 | ||
| 18 | (-> make-field (symbol string) field) | ||
| 17 | (defun make-field (name string) | 19 | (defun make-field (name string) |
| 18 | "Better constructor for `field'." | 20 | "Better constructor for `field'." |
| 19 | (make-field% :name name :string string)) | 21 | (make-field% :name name :string string)) |
| 20 | 22 | ||
| 23 | ;; TODO: list-of-fields, list-of-field-specs | ||
| 24 | (-> parse-field-specs (list) list) | ||
| 21 | (defun parse-field-specs (field-specs) | 25 | (defun parse-field-specs (field-specs) |
| 22 | "Parse a list of field specs into a list of fields." | 26 | "Parse a list of field specs into a list of fields." |
| 23 | (iter (for field-spec in field-specs) | 27 | (iter (for field-spec in field-specs) |
| 24 | (collect (apply #'make-field field-spec)))) | 28 | (collect (apply #'make-field field-spec)))) |
| 25 | 29 | ||
| 30 | (-> emit-defconst (field) list) | ||
| 26 | (defun emit-defconst (field) | 31 | (defun emit-defconst (field) |
| 27 | "Emit the `defconstant' statement for a specific field." | 32 | "Emit the `defconstant' statement for a specific field." |
| 28 | `(defconstant ,(field-name field) ',(field-name field))) | 33 | `(defconstant ,(field-name field) ',(field-name field))) |
| 29 | 34 | ||
| 35 | ;; TODO: list-of-fields | ||
| 36 | (-> emit-deftype (symbol list) list) | ||
| 30 | (defun emit-deftype (name fields) | 37 | (defun emit-deftype (name fields) |
| 31 | "Emit the `deftype' statement for the enum." | 38 | "Emit the `deftype' statement for the enum." |
| 32 | `(deftype ,name () | 39 | `(deftype ,name () |
| 33 | '(member ,@(iter (for field in fields) (collect (field-name field)))))) | 40 | '(member ,@(iter (for field in fields) (collect (field-name field)))))) |
| 34 | 41 | ||
| 42 | (-> emit-fixup-method (field) list) | ||
| 35 | (defun emit-fixup-method (field) | 43 | (defun emit-fixup-method (field) |
| 36 | "Emit the `fixup-value' specialization for the enum." | 44 | "Emit the `fixup-value' specialization for the enum." |
| 37 | (with-gensyms (arg) | 45 | (with-gensyms (arg) |
| 38 | `(defmethod fixup-value ((,arg (eql ',(field-name field)))) | 46 | `(defmethod fixup-value ((,arg (eql ',(field-name field)))) |
| 39 | ,(field-string field)))) | 47 | ,(field-string field)))) |
| 40 | 48 | ||
| 49 | (-> emit-jzon-write-method (field) list) | ||
| 41 | (defun emit-jzon-write-method (field) | 50 | (defun emit-jzon-write-method (field) |
| 42 | "Emit the `json:write-value' specialization for the enum." | 51 | "Emit the `json:write-value' specialization for the enum." |
| 43 | (with-gensyms (arg writer) | 52 | (with-gensyms (arg writer) |
| 44 | `(defmethod jzon:write-value ((,writer jzon:writer) (,arg (eql ',(field-name field)))) | 53 | `(defmethod jzon:write-value ((,writer jzon:writer) (,arg (eql ',(field-name field)))) |
| 45 | (jzon:write-value ,writer ,(field-string field))))) | 54 | (jzon:write-value ,writer ,(field-string field))))) |
| 46 | 55 | ||
| 56 | ;; TODO: list-of-fields | ||
| 57 | (-> emit-parse-value (symbol list) list) | ||
| 47 | (defun emit-parse-value (name fields) | 58 | (defun emit-parse-value (name fields) |
| 48 | "Emit the `parse-value' specialization for the enum." | 59 | "Emit the `parse-value' specialization for the enum." |
| 49 | (with-gensyms (source type) | 60 | (with-gensyms (source type) |
diff --git a/src/inline-bots.lisp b/src/inline-bots.lisp index 4361adb..f4d8a8d 100644 --- a/src/inline-bots.lisp +++ b/src/inline-bots.lisp | |||
| @@ -6,6 +6,7 @@ | |||
| 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 :serapeum :->) | ||
| 9 | (:import-from :state) | 10 | (:import-from :state) |
| 10 | (:local-nicknames (:db :ukkoclot/src/db)) | 11 | (:local-nicknames (:db :ukkoclot/src/db)) |
| 11 | (:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot)) | 12 | (:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot)) |
| @@ -13,27 +14,30 @@ | |||
| 13 | 14 | ||
| 14 | (enable-f-strings) | 15 | (enable-f-strings) |
| 15 | 16 | ||
| 17 | (-> blacklist-inline-bot (integer) (values &optional)) | ||
| 16 | (defun blacklist-inline-bot (inline-bot-id) | 18 | (defun blacklist-inline-bot (inline-bot-id) |
| 17 | "Blacklist the given bot. | 19 | "Blacklist the given bot. |
| 18 | 20 | ||
| 19 | No more messages about deleting its messages will be sent." | 21 | No more messages about deleting its messages will be sent." |
| 20 | (db:set-inline-bot-type (state:db) inline-bot-id :blacklisted)) | 22 | (db:set-inline-bot-type (state:db) inline-bot-id db:blacklisted)) |
| 21 | 23 | ||
| 24 | (-> whitelist-inline-bot (integer) (values &optional)) | ||
| 22 | (defun whitelist-inline-bot (inline-bot-id) | 25 | (defun whitelist-inline-bot (inline-bot-id) |
| 23 | "Whitelist the given bot. | 26 | "Whitelist the given bot. |
| 24 | 27 | ||
| 25 | Its messages will no longer be deleted." | 28 | Its messages will no longer be deleted." |
| 26 | (db:set-inline-bot-type (state:db) inline-bot-id :whitelisted)) | 29 | (db:set-inline-bot-type (state:db) inline-bot-id db:whitelisted)) |
| 27 | 30 | ||
| 31 | (-> on-inline-bot (message user) boolean) | ||
| 28 | (defun on-inline-bot (msg via) | 32 | (defun on-inline-bot (msg via) |
| 29 | (let ((ty (db:get-inline-bot-type (state:db) (user-id via)))) | 33 | (let ((ty (db:get-inline-bot-type (state:db) (user-id via)))) |
| 30 | (or (eql ty :whitelisted) | 34 | (or (eql ty db:whitelisted) |
| 31 | (prog1 nil | 35 | (prog1 nil |
| 32 | (log:info "Deleting an unallowed inline bot message from ~A ~A" | 36 | (log:info "Deleting an unallowed inline bot message from ~A ~A" |
| 33 | (user-username via) | 37 | (user-username via) |
| 34 | (user-id via)) | 38 | (user-id via)) |
| 35 | (try-delete-message msg) | 39 | (try-delete-message msg) |
| 36 | (unless (eql ty :blacklisted) | 40 | (unless (eql ty db:blacklisted) |
| 37 | ;; Not explicitly blacklisted, notify dev group | 41 | ;; Not explicitly blacklisted, notify dev group |
| 38 | (let ((whitelist (make-inline-keyboard-button :text "Whitelist" | 42 | (let ((whitelist (make-inline-keyboard-button :text "Whitelist" |
| 39 | :callback-data #f"bwl:{(user-id via)}")) | 43 | :callback-data #f"bwl:{(user-id via)}")) |
diff --git a/src/main.lisp b/src/main.lisp index e68ca40..4cb8c19 100644 --- a/src/main.lisp +++ b/src/main.lisp | |||
| @@ -7,7 +7,7 @@ | |||
| 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 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 :state :*state* :make-state) |
| 12 | (:import-from :str) | 12 | (:import-from :str) |
| 13 | (:import-from :ukkoclot/src/db :with-db) | 13 | (:import-from :ukkoclot/src/db :with-db) |
| @@ -22,13 +22,13 @@ | |||
| 22 | 22 | ||
| 23 | (defvar *in-prod* nil) | 23 | (defvar *in-prod* nil) |
| 24 | 24 | ||
| 25 | (-> main () (values &optional)) | ||
| 25 | (defun main () | 26 | (defun main () |
| 26 | (unwind-protect | 27 | (unwind-protect |
| 27 | (progn | 28 | (progn |
| 28 | (conf:load-config #P"config.lisp") | 29 | (conf:load-config #P"config.lisp") |
| 29 | (log:info "Starting up ~A" (conf:bot-name)) | 30 | (log:info "Starting up ~A" (conf:bot-name)) |
| 30 | (main-with-config) | 31 | (main-with-config)) |
| 31 | nil) | ||
| 32 | (log:info "Quitting!"))) | 32 | (log:info "Quitting!"))) |
| 33 | 33 | ||
| 34 | (defmacro reporty ((evt) &body body) | 34 | (defmacro reporty ((evt) &body body) |
| @@ -38,6 +38,7 @@ | |||
| 38 | (error (err) (report-error ,evt err)))) | 38 | (error (err) (report-error ,evt err)))) |
| 39 | (t ,@body))) | 39 | (t ,@body))) |
| 40 | 40 | ||
| 41 | (-> main-with-config () (values &optional)) | ||
| 41 | (defun main-with-config () | 42 | (defun main-with-config () |
| 42 | (unwind-protect | 43 | (unwind-protect |
| 43 | (with-db (db (conf:db-path)) | 44 | (with-db (db (conf:db-path)) |
| @@ -46,6 +47,7 @@ | |||
| 46 | (wrapped-main)) | 47 | (wrapped-main)) |
| 47 | (log:info "We're done!"))) | 48 | (log:info "We're done!"))) |
| 48 | 49 | ||
| 50 | (-> wrapped-main () (values &optional)) | ||
| 49 | (defun wrapped-main () | 51 | (defun wrapped-main () |
| 50 | (when *in-prod* | 52 | (when *in-prod* |
| 51 | (send-message :chat-id (conf:dev-group) :text "Initializing...")) | 53 | (send-message :chat-id (conf:dev-group) :text "Initializing...")) |
| @@ -65,8 +67,10 @@ | |||
| 65 | (setf gup-offset (1+ (update-update-id update))))))) | 67 | (setf gup-offset (1+ (update-update-id update))))))) |
| 66 | ;; One last getUpdates to make sure offset is stored on server | 68 | ;; One last getUpdates to make sure offset is stored on server |
| 67 | (get-updates :timeout 0 :limit 1 :offset gup-offset)) | 69 | (get-updates :timeout 0 :limit 1 :offset gup-offset)) |
| 68 | (send-message :chat-id (conf:dev-group) :text "Shutting down...")) | 70 | (send-message :chat-id (conf:dev-group) :text "Shutting down...") |
| 71 | (values)) | ||
| 69 | 72 | ||
| 73 | (-> on-callback-query (callback-query) (values &optional)) | ||
| 70 | (defun on-callback-query (cb) | 74 | (defun on-callback-query (cb) |
| 71 | (let ((data (callback-query-data cb))) | 75 | (let ((data (callback-query-data cb))) |
| 72 | (cond ((and data | 76 | (cond ((and data |
| @@ -95,9 +99,10 @@ | |||
| 95 | (log:info "Unrecognised callback query data: ~A" data) | 99 | (log:info "Unrecognised callback query data: ~A" data) |
| 96 | (answer-callback-query :callback-query-id (callback-query-id cb) | 100 | (answer-callback-query :callback-query-id (callback-query-id cb) |
| 97 | :text "Unallowed callback query, don't press the button again" | 101 | :text "Unallowed callback query, don't press the button again" |
| 98 | :show-alert t))))) | 102 | :show-alert t)))) |
| 99 | 103 | (values)) | |
| 100 | 104 | ||
| 105 | (-> on-message (message) (values &optional)) | ||
| 101 | (defun on-message (msg) | 106 | (defun on-message (msg) |
| 102 | (block nil | 107 | (block nil |
| 103 | (when-let (inline-bot (message-via-bot msg)) | 108 | (when-let (inline-bot (message-via-bot msg)) |
| @@ -110,8 +115,10 @@ | |||
| 110 | (when-let (new-chat-members (message-new-chat-members msg)) | 115 | (when-let (new-chat-members (message-new-chat-members msg)) |
| 111 | (iter | 116 | (iter |
| 112 | (for new-chat-member in-vector new-chat-members) | 117 | (for new-chat-member in-vector new-chat-members) |
| 113 | (on-new-member msg new-chat-member))))) | 118 | (on-new-member msg new-chat-member)))) |
| 119 | (values)) | ||
| 114 | 120 | ||
| 121 | (-> on-new-member (message user) (values &optional)) | ||
| 115 | (defun on-new-member (msg new-member) | 122 | (defun on-new-member (msg new-member) |
| 116 | (if (= (user-id new-member) (bot-id)) | 123 | (if (= (user-id new-member) (bot-id)) |
| 117 | (reply-animation msg #P"blob/rule-11.mp4" | 124 | (reply-animation msg #P"blob/rule-11.mp4" |
| @@ -122,13 +129,16 @@ | |||
| 122 | "! Be on your bestest behaviour now!!") | 129 | "! Be on your bestest behaviour now!!") |
| 123 | :parse-mode html | 130 | :parse-mode html |
| 124 | :caption-above t | 131 | :caption-above t |
| 125 | :allow-sending-without-reply t))) | 132 | :allow-sending-without-reply t)) |
| 133 | (values)) | ||
| 126 | 134 | ||
| 135 | (-> is-bad-text (string) boolean) | ||
| 127 | (defun is-bad-text (text) | 136 | (defun is-bad-text (text) |
| 128 | (declare (ignore text)) | 137 | (declare (ignore text)) |
| 129 | ;; TODO: | 138 | ;; TODO: |
| 130 | nil) | 139 | nil) |
| 131 | 140 | ||
| 141 | (-> on-text-message (message string) (values &optional)) | ||
| 132 | (defun on-text-message (msg text) | 142 | (defun on-text-message (msg text) |
| 133 | (block nil | 143 | (block nil |
| 134 | (when (is-bad-text text) | 144 | (when (is-bad-text text) |
| @@ -141,7 +151,7 @@ | |||
| 141 | ;; 5 current warns: Ban | 151 | ;; 5 current warns: Ban |
| 142 | ;; | 152 | ;; |
| 143 | ;; warn gets removed after a month of no warns | 153 | ;; warn gets removed after a month of no warns |
| 144 | (return)) | 154 | (return (values))) |
| 145 | 155 | ||
| 146 | (when-let (entities (message-entities msg)) | 156 | (when-let (entities (message-entities msg)) |
| 147 | (iter | 157 | (iter |
| @@ -223,8 +233,10 @@ | |||
| 223 | (write-char #\l s) | 233 | (write-char #\l s) |
| 224 | (write-char #\L s))))) | 234 | (write-char #\L s))))) |
| 225 | 235 | ||
| 226 | (t nil)))) | 236 | (t nil))) |
| 237 | (values)) | ||
| 227 | 238 | ||
| 239 | (-> simplify-cmd (string) (or string null)) | ||
| 228 | (defun simplify-cmd (cmd) | 240 | (defun simplify-cmd (cmd) |
| 229 | (let ((at-idx (position #\@ cmd))) | 241 | (let ((at-idx (position #\@ cmd))) |
| 230 | (if (null at-idx) | 242 | (if (null at-idx) |
| @@ -235,6 +247,7 @@ | |||
| 235 | (subseq cmd 1 at-idx) | 247 | (subseq cmd 1 at-idx) |
| 236 | nil))))) | 248 | nil))))) |
| 237 | 249 | ||
| 250 | (-> on-text-command (message string string) (values &optional)) | ||
| 238 | (defun on-text-command (msg text cmd) | 251 | (defun on-text-command (msg text cmd) |
| 239 | (declare (ignore text)) | 252 | (declare (ignore text)) |
| 240 | (let ((simple-cmd (simplify-cmd cmd))) | 253 | (let ((simple-cmd (simplify-cmd cmd))) |
| @@ -264,14 +277,18 @@ | |||
| 264 | (message-from msg) | 277 | (message-from msg) |
| 265 | (= (user-id (message-from msg)) (conf:owner))) | 278 | (= (user-id (message-from msg)) (conf:owner))) |
| 266 | (setf (state:power-on) nil) | 279 | (setf (state:power-on) nil) |
| 267 | (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t))))) | 280 | (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t)))) |
| 281 | (values)) | ||
| 268 | 282 | ||
| 283 | (-> escape-xml-obj (t) string) | ||
| 269 | (defun escape-xml-obj (obj) | 284 | (defun escape-xml-obj (obj) |
| 270 | (escape-xml #f"{obj}")) | 285 | (escape-xml #f"{obj}")) |
| 271 | 286 | ||
| 287 | (-> report-error (t t) (values &optional)) | ||
| 272 | (defun report-error (evt err) | 288 | (defun report-error (evt err) |
| 273 | (log:error "While handling ~A: ~A" evt err) | 289 | (log:error "While handling ~A: ~A" evt err) |
| 274 | (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>")) | 290 | (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>")) |
| 275 | (send-message :chat-id (conf:dev-group) | 291 | (send-message :chat-id (conf:dev-group) |
| 276 | :text msg | 292 | :text msg |
| 277 | :parse-mode html))) | 293 | :parse-mode html)) |
| 294 | (values)) | ||
diff --git a/src/rw-lock.lisp b/src/rw-lock.lisp index dc8850d..b8d08b1 100644 --- a/src/rw-lock.lisp +++ b/src/rw-lock.lisp | |||
| @@ -7,6 +7,7 @@ | |||
| 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 8 | (:import-from :sb-sys | 8 | (:import-from :sb-sys |
| 9 | :allow-with-interrupts :with-local-interrupts :without-interrupts) | 9 | :allow-with-interrupts :with-local-interrupts :without-interrupts) |
| 10 | (:import-from :serapeum :->) | ||
| 10 | (:export | 11 | (:export |
| 11 | #:rw-lock | 12 | #:rw-lock |
| 12 | #:rw-lock-p | 13 | #:rw-lock-p |
| @@ -36,12 +37,14 @@ | |||
| 36 | 37 | ||
| 37 | (defvar *counter* 0) | 38 | (defvar *counter* 0) |
| 38 | 39 | ||
| 40 | (-> gen-name () string) | ||
| 39 | (defun gen-name () | 41 | (defun gen-name () |
| 40 | "Generate a name for a rw-lock" | 42 | "Generate a name for a rw-lock" |
| 41 | (format nil "Read-Write Lock ~A" | 43 | (format nil "Read-Write Lock ~A" |
| 42 | (with-lock-held (*counter-lock*) | 44 | (with-lock-held (*counter-lock*) |
| 43 | (incf *counter*)))) | 45 | (incf *counter*)))) |
| 44 | 46 | ||
| 47 | (-> make-rw-lock (&key (:name string)) rw-lock) | ||
| 45 | (defun make-rw-lock (&key (name (gen-name))) | 48 | (defun make-rw-lock (&key (name (gen-name))) |
| 46 | (check-type name string) | 49 | (check-type name string) |
| 47 | (make-rw-lock% | 50 | (make-rw-lock% |
| @@ -49,6 +52,7 @@ | |||
| 49 | :reader-cv (make-condition-variable :name #f"{name}'s internal reader-cv") | 52 | :reader-cv (make-condition-variable :name #f"{name}'s internal reader-cv") |
| 50 | :writer-cv (make-condition-variable :name #f"{name}'s internal writer-cv"))) | 53 | :writer-cv (make-condition-variable :name #f"{name}'s internal writer-cv"))) |
| 51 | 54 | ||
| 55 | (-> wakeup-waiters (rw-lock) (values &optional)) | ||
| 52 | (defun wakeup-waiters (rw-lock) | 56 | (defun wakeup-waiters (rw-lock) |
| 53 | ;; NOTE: RW-LOCK-LOCK HAS TO BE TAKEN! | 57 | ;; NOTE: RW-LOCK-LOCK HAS TO BE TAKEN! |
| 54 | (declare (type rw-lock rw-lock)) | 58 | (declare (type rw-lock rw-lock)) |
| @@ -57,8 +61,10 @@ | |||
| 57 | ((zerop waiting-readers) (condition-notify writer-cv)) | 61 | ((zerop waiting-readers) (condition-notify writer-cv)) |
| 58 | ((zerop waiting-writers) (condition-broadcast reader-cv)) | 62 | ((zerop waiting-writers) (condition-broadcast reader-cv)) |
| 59 | (t (whichever (condition-notify writer-cv) | 63 | (t (whichever (condition-notify writer-cv) |
| 60 | (condition-broadcast reader-cv)))))) | 64 | (condition-broadcast reader-cv))))) |
| 65 | (values)) | ||
| 61 | 66 | ||
| 67 | (-> acquire-read-lock (rw-lock &key (:wait boolean)) boolean) | ||
| 62 | (defun acquire-read-lock (rw-lock &key (wait t)) | 68 | (defun acquire-read-lock (rw-lock &key (wait t)) |
| 63 | ;; TODO: timeout | 69 | ;; TODO: timeout |
| 64 | (check-type rw-lock rw-lock) | 70 | (check-type rw-lock rw-lock) |
| @@ -83,6 +89,7 @@ | |||
| 83 | (decf waiting-readers) | 89 | (decf waiting-readers) |
| 84 | (release-lock lock))))))) | 90 | (release-lock lock))))))) |
| 85 | 91 | ||
| 92 | (-> release-read-lock (rw-lock) rw-lock) | ||
| 86 | (defun release-read-lock (rw-lock) | 93 | (defun release-read-lock (rw-lock) |
| 87 | (check-type rw-lock rw-lock) | 94 | (check-type rw-lock rw-lock) |
| 88 | (with-slots (lock active-readers active-writer) rw-lock | 95 | (with-slots (lock active-readers active-writer) rw-lock |
| @@ -107,6 +114,7 @@ | |||
| 107 | (when ,lock-acquired | 114 | (when ,lock-acquired |
| 108 | (release-read-lock ,lock-value))))))) | 115 | (release-read-lock ,lock-value))))))) |
| 109 | 116 | ||
| 117 | (-> acquire-write-lock (rw-lock &key (:wait boolean)) boolean) | ||
| 110 | (defun acquire-write-lock (rw-lock &key (wait t)) | 118 | (defun acquire-write-lock (rw-lock &key (wait t)) |
| 111 | ;; TODO: timeout | 119 | ;; TODO: timeout |
| 112 | (check-type rw-lock rw-lock) | 120 | (check-type rw-lock rw-lock) |
| @@ -131,6 +139,7 @@ | |||
| 131 | (decf waiting-writers) | 139 | (decf waiting-writers) |
| 132 | (release-lock lock))))))) | 140 | (release-lock lock))))))) |
| 133 | 141 | ||
| 142 | (-> release-write-lock (rw-lock) rw-lock) | ||
| 134 | (defun release-write-lock (rw-lock) | 143 | (defun release-write-lock (rw-lock) |
| 135 | (check-type rw-lock rw-lock) | 144 | (check-type rw-lock rw-lock) |
| 136 | (with-slots (lock active-readers active-writer) rw-lock | 145 | (with-slots (lock active-readers active-writer) rw-lock |
diff --git a/src/serializing.lisp b/src/serializing.lisp index e9c46f6..b40ac75 100644 --- a/src/serializing.lisp +++ b/src/serializing.lisp | |||
| @@ -3,18 +3,21 @@ | |||
| 3 | (defpackage :ukkoclot/src/serializing | 3 | (defpackage :ukkoclot/src/serializing |
| 4 | (:use :c2cl :iterate) | 4 | (:use :c2cl :iterate) |
| 5 | (:import-from :log) | 5 | (:import-from :log) |
| 6 | (:import-from :serapeum :->) | ||
| 6 | (:import-from :str) | 7 | (:import-from :str) |
| 7 | (:local-nicknames | 8 | (:local-nicknames |
| 8 | (:jzon :com.inuoe.jzon)) | 9 | (:jzon :com.inuoe.jzon)) |
| 9 | (:export :fixup-args :fixup-value :parse-value :try-parse-value)) | 10 | (:export :fixup-args :fixup-value :parse-value :try-parse-value)) |
| 10 | (in-package :ukkoclot/src/serializing) | 11 | (in-package :ukkoclot/src/serializing) |
| 11 | 12 | ||
| 13 | ;; TODO: Better types, input is an (alist t t) output is an (alist string t) | ||
| 14 | (-> fixup-args (list) list) | ||
| 12 | (defun fixup-args (args) | 15 | (defun fixup-args (args) |
| 13 | (iter (for (key . value) in args) | 16 | (iter (for (key . value) in args) |
| 14 | (collect (cons (str:snake-case key) (fixup-value value))))) | 17 | (collect (cons (str:snake-case key) (fixup-value value))))) |
| 15 | 18 | ||
| 16 | (defgeneric fixup-value (value) | 19 | (defgeneric fixup-value (value) |
| 17 | (:documentation "Fixup outgoing *top-level* `value' before passing it to telegram.") | 20 | (:documentation "Fixup outgoing /top-level/ `value' before passing it to telegram.") |
| 18 | (:method (value) | 21 | (:method (value) |
| 19 | (jzon:stringify value :pretty *print-pretty*)) | 22 | (jzon:stringify value :pretty *print-pretty*)) |
| 20 | (:method ((value null)) | 23 | (:method ((value null)) |
| @@ -61,6 +64,7 @@ | |||
| 61 | (t | 64 | (t |
| 62 | (error "I don't know how to parse complex type ~A!" type)))) | 65 | (error "I don't know how to parse complex type ~A!" type)))) |
| 63 | 66 | ||
| 67 | (-> try-parse-value (t t) (values boolean t &optional)) | ||
| 64 | (defun try-parse-value (type json) | 68 | (defun try-parse-value (type json) |
| 65 | (handler-case (values t (parse-value type json)) | 69 | (handler-case (values t (parse-value type json)) |
| 66 | (error () (values nil nil)))) | 70 | (error () (values nil nil)))) |
diff --git a/src/state.lisp b/src/state.lisp index ef4050d..9f1a38f 100644 --- a/src/state.lisp +++ b/src/state.lisp | |||
| @@ -5,8 +5,9 @@ | |||
| 5 | (:nicknames :state) | 5 | (:nicknames :state) |
| 6 | (:use :c2cl :ukkoclot/src/rw-lock) | 6 | (:use :c2cl :ukkoclot/src/rw-lock) |
| 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 8 | (:import-from :conf :*config* :bot-token) | 8 | (:import-from :conf :config :*config* :bot-token) |
| 9 | (:import-from :sqlite :sqlite-handle) | 9 | (:import-from :serapeum :->) |
| 10 | (:import-from :ukkoclot/src/db :db) | ||
| 10 | (:export | 11 | (:export |
| 11 | #:*state* | 12 | #:*state* |
| 12 | #:state | 13 | #:state |
| @@ -26,38 +27,44 @@ | |||
| 26 | 27 | ||
| 27 | (defstruct (state (:constructor make-state%)) | 28 | (defstruct (state (:constructor make-state%)) |
| 28 | (lock (make-rw-lock :name "state's lock") :type rw-lock :read-only t) | 29 | (lock (make-rw-lock :name "state's lock") :type rw-lock :read-only t) |
| 29 | (db (error "No value given for DB") :type sqlite-handle :read-only t) | 30 | (db (error "No value given for DB") :type db :read-only t) |
| 30 | (base-uri (error "No value given for base-uri") :type string :read-only t) | 31 | (base-uri (error "No value given for base-uri") :type string :read-only t) |
| 31 | (power-on t :type boolean) | 32 | (power-on t :type boolean) |
| 32 | (username% nil :type (or string null)) | 33 | (username% nil :type (or string null)) |
| 33 | (id% nil :type (or integer null))) | 34 | (id% nil :type (or integer null))) |
| 34 | 35 | ||
| 36 | (-> make-state (db &optional config) state) | ||
| 35 | (defun make-state (db &optional (config *config*)) | 37 | (defun make-state (db &optional (config *config*)) |
| 36 | (check-type db sqlite-handle) | 38 | (check-type db db) |
| 37 | (let ((base-uri #f"https://api.telegram.org/bot{(bot-token config)}/")) | 39 | (let ((base-uri #f"https://api.telegram.org/bot{(bot-token config)}/")) |
| 38 | (make-state% :db db :base-uri base-uri))) | 40 | (make-state% :db db :base-uri base-uri))) |
| 39 | 41 | ||
| 40 | (defvar *state* nil | 42 | (defvar *state* nil |
| 41 | "Bot's general state. You should initialise this with a value before doing anything fun.") | 43 | "Bot's general state. You should initialise this with a value before doing anything fun.") |
| 44 | (declaim (type (or state null) *state*)) | ||
| 42 | 45 | ||
| 46 | (-> db (&optional state) db) | ||
| 43 | (defun db (&optional (state *state*)) | 47 | (defun db (&optional (state *state*)) |
| 44 | "Get the database handle of the bot." | 48 | "Get the database handle of the bot." |
| 45 | (with-slots (lock db) state | 49 | (with-slots (lock db) state |
| 46 | (with-read-lock (lock) | 50 | (with-read-lock (lock) |
| 47 | db))) | 51 | db))) |
| 48 | 52 | ||
| 53 | (-> base-uri (&optional state) string) | ||
| 49 | (defun base-uri (&optional (state *state*)) | 54 | (defun base-uri (&optional (state *state*)) |
| 50 | "Get the base URI of the bot." | 55 | "Get the base URI of the bot." |
| 51 | (with-slots (lock base-uri) state | 56 | (with-slots (lock base-uri) state |
| 52 | (with-read-lock (lock) | 57 | (with-read-lock (lock) |
| 53 | base-uri))) | 58 | base-uri))) |
| 54 | 59 | ||
| 60 | (-> power-on (&optional state) boolean) | ||
| 55 | (defun power-on (&optional (state *state*)) | 61 | (defun power-on (&optional (state *state*)) |
| 56 | "Get whether the bot is running" | 62 | "Get whether the bot is running" |
| 57 | (with-slots (lock power-on) state | 63 | (with-slots (lock power-on) state |
| 58 | (with-read-lock (lock) | 64 | (with-read-lock (lock) |
| 59 | power-on))) | 65 | power-on))) |
| 60 | 66 | ||
| 67 | (-> set-power-on (boolean &optional state) boolean) | ||
| 61 | (defun set-power-on (new-value &optional (state *state*)) | 68 | (defun set-power-on (new-value &optional (state *state*)) |
| 62 | "Set the value of the power-on" | 69 | "Set the value of the power-on" |
| 63 | (with-slots (lock power-on) state | 70 | (with-slots (lock power-on) state |
| @@ -67,12 +74,14 @@ | |||
| 67 | (defsetf power-on (&optional (state '*state*)) (new-value) | 74 | (defsetf power-on (&optional (state '*state*)) (new-value) |
| 68 | `(set-power-on ,new-value ,state)) | 75 | `(set-power-on ,new-value ,state)) |
| 69 | 76 | ||
| 77 | (-> username% (&optional state) (or string null)) | ||
| 70 | (defun username% (&optional (state *state*)) | 78 | (defun username% (&optional (state *state*)) |
| 71 | "Get the cached bot's username, you should probably use `ukkoclot/src/tg:bot-username' instead." | 79 | "Get the cached bot's username, you should probably use `ukkoclot/src/tg:bot-username' instead." |
| 72 | (with-slots (lock username%) state | 80 | (with-slots (lock username%) state |
| 73 | (with-read-lock (lock) | 81 | (with-read-lock (lock) |
| 74 | username%))) | 82 | username%))) |
| 75 | 83 | ||
| 84 | (-> set-username% (string &optional state) string) | ||
| 76 | (defun set-username% (new-value &optional (state *state*)) | 85 | (defun set-username% (new-value &optional (state *state*)) |
| 77 | (with-slots (lock username%) state | 86 | (with-slots (lock username%) state |
| 78 | (with-write-lock (lock) | 87 | (with-write-lock (lock) |
| @@ -81,12 +90,14 @@ | |||
| 81 | (defsetf username% (&optional (state '*state*)) (new-value) | 90 | (defsetf username% (&optional (state '*state*)) (new-value) |
| 82 | `(set-username% ,new-value ,state)) | 91 | `(set-username% ,new-value ,state)) |
| 83 | 92 | ||
| 93 | (-> id% (&optional state) (or integer null)) | ||
| 84 | (defun id% (&optional (state *state*)) | 94 | (defun id% (&optional (state *state*)) |
| 85 | "Get the cached bot's ID, you should probably use `ukkoclot/src/tg:bot-id' instead." | 95 | "Get the cached bot's ID, you should probably use `ukkoclot/src/tg:bot-id' instead." |
| 86 | (with-slots (lock id%) state | 96 | (with-slots (lock id%) state |
| 87 | (with-read-lock (lock) | 97 | (with-read-lock (lock) |
| 88 | id%))) | 98 | id%))) |
| 89 | 99 | ||
| 100 | (-> set-id% (integer &optional state) integer) | ||
| 90 | (defun set-id% (new-value &optional (state *state*)) | 101 | (defun set-id% (new-value &optional (state *state*)) |
| 91 | (with-slots (lock id%) state | 102 | (with-slots (lock id%) state |
| 92 | (with-write-lock (lock) | 103 | (with-write-lock (lock) |
diff --git a/src/strings.lisp b/src/strings.lisp index 04a20de..ab9f13c 100644 --- a/src/strings.lisp +++ b/src/strings.lisp | |||
| @@ -4,6 +4,8 @@ | |||
| 4 | (:documentation "String-oriented utilities.") | 4 | (:documentation "String-oriented utilities.") |
| 5 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :cl-unicode :general-category) | 6 | (:import-from :cl-unicode :general-category) |
| 7 | (:import-from :serapeum :->) | ||
| 8 | (:import-from :ukkoclot/src/streams :with-format-like-stream) | ||
| 7 | (:export | 9 | (:export |
| 8 | :escape-xml | 10 | :escape-xml |
| 9 | :is-tg-whitespace | 11 | :is-tg-whitespace |
| @@ -12,27 +14,20 @@ | |||
| 12 | 14 | ||
| 13 | ;; These are very inefficient but I don't care until I profile | 15 | ;; These are very inefficient but I don't care until I profile |
| 14 | 16 | ||
| 15 | (defun escape-xml (str &optional out) | 17 | (-> escape-xml (string &optional (or stream boolean)) (or string null)) |
| 16 | "Escape special XML characters in the STR. | 18 | (defun escape-xml (str &optional out-spec) |
| 17 | 19 | "Escape special XML characters in the STR." | |
| 18 | OUT is the output stream or `nil' for outputting to a string." | 20 | (with-format-like-stream (out out-spec) |
| 19 | (if out | 21 | (iter |
| 20 | (escape-xml% str out) | 22 | (for ch in-string str) |
| 21 | (with-output-to-string (out) | 23 | (case ch |
| 22 | (escape-xml% str out)))) | 24 | (#\< (write-string "<" out)) |
| 23 | 25 | (#\> (write-string ">" out)) | |
| 24 | (defun escape-xml% (str out) | 26 | (#\& (write-string "&" out)) |
| 25 | "See `escape-xml'. | 27 | (#\" (write-string """ out)) |
| 26 | 28 | (otherwise (write-char ch out)))))) | |
| 27 | OUT is always the stream." | ||
| 28 | (loop for ch across str do | ||
| 29 | (case ch | ||
| 30 | (#\< (write-string "<" out)) | ||
| 31 | (#\> (write-string ">" out)) | ||
| 32 | (#\& (write-string "&" out)) | ||
| 33 | (#\" (write-string """ out)) | ||
| 34 | (otherwise (write-char ch out))))) | ||
| 35 | 29 | ||
| 30 | (-> is-tg-whitespace (character) boolean) | ||
| 36 | (defun is-tg-whitespace (ch) | 31 | (defun is-tg-whitespace (ch) |
| 37 | "Checks if CH on its own would be considered whitespace by telegram." | 32 | "Checks if CH on its own would be considered whitespace by telegram." |
| 38 | (let ((gc (general-category ch))) | 33 | (let ((gc (general-category ch))) |
| @@ -42,6 +37,7 @@ OUT is always the stream." | |||
| 42 | (string= gc "Cc") ; Other, control | 37 | (string= gc "Cc") ; Other, control |
| 43 | (= (char-code ch) #x2800)))) ; BRAILLE PATTERN BLANK | 38 | (= (char-code ch) #x2800)))) ; BRAILLE PATTERN BLANK |
| 44 | 39 | ||
| 40 | (-> is-tg-whitespace-str (string) boolean) | ||
| 45 | (defun is-tg-whitespace-str (str) | 41 | (defun is-tg-whitespace-str (str) |
| 46 | "Checks if message containing just STR would be considered whitespace by telegram." | 42 | "Checks if message containing just STR would be considered whitespace by telegram." |
| 47 | (iter (for ch in-string str) | 43 | (iter (for ch in-string str) |
diff --git a/src/tg/delete-message.lisp b/src/tg/delete-message.lisp index 2b332df..44fccd2 100644 --- a/src/tg/delete-message.lisp +++ b/src/tg/delete-message.lisp | |||
| @@ -3,6 +3,7 @@ | |||
| 3 | (defpackage :ukkoclot/src/tg/delete-message | 3 | (defpackage :ukkoclot/src/tg/delete-message |
| 4 | (:documentation "deleteMessage Telegram method") | 4 | (:documentation "deleteMessage Telegram method") |
| 5 | (: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) |
| 6 | (:import-from :serapeum :->) | ||
| 6 | (:export :delete-message :try-delete-message)) | 7 | (:export :delete-message :try-delete-message)) |
| 7 | (in-package :ukkoclot/src/tg/delete-message) | 8 | (in-package :ukkoclot/src/tg/delete-message) |
| 8 | 9 | ||
| @@ -10,6 +11,7 @@ | |||
| 10 | (chat-id (or integer string)) | 11 | (chat-id (or integer string)) |
| 11 | (message-id integer)) | 12 | (message-id integer)) |
| 12 | 13 | ||
| 14 | (-> try-delete-message (message) boolean) | ||
| 13 | (defun try-delete-message (msg) | 15 | (defun try-delete-message (msg) |
| 14 | "Attempt to delete the MSG, on failure reply with a GIF of the DO NOT cat." | 16 | "Attempt to delete the MSG, on failure reply with a GIF of the DO NOT cat." |
| 15 | (handler-case | 17 | (handler-case |
| @@ -17,6 +19,7 @@ | |||
| 17 | :message-id (message-id msg)) | 19 | :message-id (message-id msg)) |
| 18 | (error () | 20 | (error () |
| 19 | (handler-case | 21 | (handler-case |
| 20 | (reply-animation msg #P"blob/do-not.mp4" | 22 | (prog1 nil |
| 21 | :allow-sending-without-reply nil) | 23 | (reply-animation msg #P"blob/do-not.mp4" |
| 24 | :allow-sending-without-reply nil)) | ||
| 22 | (error () nil))))) | 25 | (error () nil))))) |
diff --git a/src/tg/get-me.lisp b/src/tg/get-me.lisp index e7d41a1..5360f16 100644 --- a/src/tg/get-me.lisp +++ b/src/tg/get-me.lisp | |||
| @@ -3,12 +3,14 @@ | |||
| 3 | (defpackage :ukkoclot/src/tg/get-me | 3 | (defpackage :ukkoclot/src/tg/get-me |
| 4 | (:documentation "getMe Telegram method") | 4 | (:documentation "getMe Telegram method") |
| 5 | (:use :c2cl :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/user) | 5 | (:use :c2cl :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/user) |
| 6 | (:import-from :serapeum :->) | ||
| 6 | (:import-from :state) | 7 | (:import-from :state) |
| 7 | (:export :bot-id :bot-username :get-me)) | 8 | (:export :bot-id :bot-username :get-me)) |
| 8 | (in-package :ukkoclot/src/tg/get-me) | 9 | (in-package :ukkoclot/src/tg/get-me) |
| 9 | 10 | ||
| 10 | (define-tg-method (get-me% user :GET)) | 11 | (define-tg-method (get-me% user :GET)) |
| 11 | 12 | ||
| 13 | (-> get-me () user) | ||
| 12 | (defun get-me () | 14 | (defun get-me () |
| 13 | "getMe Telegram method" | 15 | "getMe Telegram method" |
| 14 | (let ((me (get-me%))) | 16 | (let ((me (get-me%))) |
| @@ -16,6 +18,7 @@ | |||
| 16 | (setf (state:username%) (user-username me)) | 18 | (setf (state:username%) (user-username me)) |
| 17 | me)) | 19 | me)) |
| 18 | 20 | ||
| 21 | (-> bot-id () integer) | ||
| 19 | (defun bot-id () | 22 | (defun bot-id () |
| 20 | "Get the bot's ID, this memoizes the result" | 23 | "Get the bot's ID, this memoizes the result" |
| 21 | (or (state:id%) | 24 | (or (state:id%) |
| @@ -23,6 +26,7 @@ | |||
| 23 | (get-me) | 26 | (get-me) |
| 24 | (state:id%)))) | 27 | (state:id%)))) |
| 25 | 28 | ||
| 29 | (-> bot-username () string) | ||
| 26 | (defun bot-username () | 30 | (defun bot-username () |
| 27 | "Get the bot's username, this memoizes the result" | 31 | "Get the bot's username, this memoizes the result" |
| 28 | (or (state:username%) | 32 | (or (state:username%) |
diff --git a/src/tg/message-entity.lisp b/src/tg/message-entity.lisp index 1a8cd27..c87dca0 100644 --- a/src/tg/message-entity.lisp +++ b/src/tg/message-entity.lisp | |||
| @@ -3,6 +3,7 @@ | |||
| 3 | (defpackage :ukkoclot/src/tg/message-entity | 3 | (defpackage :ukkoclot/src/tg/message-entity |
| 4 | (:documentation "MessageEntity Telegram type") | 4 | (:documentation "MessageEntity Telegram type") |
| 5 | (:use :c2cl :iterate :ukkoclot/src/enum :ukkoclot/src/tg/type-macros :ukkoclot/src/tg/user) | 5 | (:use :c2cl :iterate :ukkoclot/src/enum :ukkoclot/src/tg/type-macros :ukkoclot/src/tg/user) |
| 6 | (:import-from :serapeum :->) | ||
| 6 | (:export | 7 | (:export |
| 7 | #:message-entity-type | 8 | #:message-entity-type |
| 8 | #:mention | 9 | #:mention |
| @@ -72,6 +73,7 @@ | |||
| 72 | (unless (= char-code-limit #x110000) | 73 | (unless (= char-code-limit #x110000) |
| 73 | (error "Some UTF-16 fuckery assumes that system chars are UTF-32")) | 74 | (error "Some UTF-16 fuckery assumes that system chars are UTF-32")) |
| 74 | 75 | ||
| 76 | (-> utf16-width (character) (member 1 2)) | ||
| 75 | (defun utf16-width (ch) | 77 | (defun utf16-width (ch) |
| 76 | "Calculate the size of char in UTF-16 units." | 78 | "Calculate the size of char in UTF-16 units." |
| 77 | (declare (type character ch)) | 79 | (declare (type character ch)) |
| @@ -79,6 +81,7 @@ | |||
| 79 | 1 | 81 | 1 |
| 80 | 2)) | 82 | 2)) |
| 81 | 83 | ||
| 84 | (-> message-entity-extract (message-entity string) string) | ||
| 82 | (defun message-entity-extract (entity text) | 85 | (defun message-entity-extract (entity text) |
| 83 | "Extract the text corresponding to the ENTITY from the message text (in TEXT)." | 86 | "Extract the text corresponding to the ENTITY from the message text (in TEXT)." |
| 84 | (check-type entity message-entity) | 87 | (check-type entity message-entity) |
diff --git a/src/tg/message.lisp b/src/tg/message.lisp index 13162a5..70155ab 100644 --- a/src/tg/message.lisp +++ b/src/tg/message.lisp | |||
| @@ -10,6 +10,7 @@ | |||
| 10 | :ukkoclot/src/tg/photo-size | 10 | :ukkoclot/src/tg/photo-size |
| 11 | :ukkoclot/src/tg/type-macros | 11 | :ukkoclot/src/tg/type-macros |
| 12 | :ukkoclot/src/tg/user) | 12 | :ukkoclot/src/tg/user) |
| 13 | (:import-from :serapeum :-> :defsubst) | ||
| 13 | (:export | 14 | (:export |
| 14 | #:message-chat-id | 15 | #:message-chat-id |
| 15 | #:message-thread-id | 16 | #:message-thread-id |
| @@ -163,17 +164,17 @@ | |||
| 163 | ;; (reply-markup (or inline-keyboard-markup null) nil) | 164 | ;; (reply-markup (or inline-keyboard-markup null) nil) |
| 164 | ) ; lint:suppress closing-parens-same-line whitespace-before-close-paren | 165 | ) ; lint:suppress closing-parens-same-line whitespace-before-close-paren |
| 165 | 166 | ||
| 166 | (declaim (inline message-id)) | 167 | (-> message-id (message) integer) |
| 167 | (defun message-id (msg) | 168 | (defsubst message-id (msg) |
| 168 | "Better named version of `message-message-id'." | 169 | "Better named version of `message-message-id'." |
| 169 | (message-message-id msg)) | 170 | (message-message-id msg)) |
| 170 | 171 | ||
| 171 | (declaim (inline message-chat-id)) | 172 | (-> message-chat-id (message) integer) |
| 172 | (defun message-chat-id (msg) | 173 | (defsubst message-chat-id (msg) |
| 173 | "Shortcut for (CHAT-ID (MESSAGE-CHAT MSG))." | 174 | "Shortcut for (CHAT-ID (MESSAGE-CHAT MSG))." |
| 174 | (chat-id (message-chat msg))) | 175 | (chat-id (message-chat msg))) |
| 175 | 176 | ||
| 176 | (declaim (inline message-thread-id)) | 177 | (-> message-thread-id (message) (or integer null)) |
| 177 | (defun message-thread-id (msg) | 178 | (defsubst message-thread-id (msg) |
| 178 | "Better named version of `message-message-thread-id'." | 179 | "Better named version of `message-message-thread-id'." |
| 179 | (message-message-thread-id msg)) | 180 | (message-message-thread-id msg)) |
diff --git a/src/tg/method-macros.lisp b/src/tg/method-macros.lisp index 0d33ffb..9ab9e89 100644 --- a/src/tg/method-macros.lisp +++ b/src/tg/method-macros.lisp | |||
| @@ -5,10 +5,10 @@ | |||
| 5 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :alexandria :make-keyword :with-gensyms) | 6 | (:import-from :alexandria :make-keyword :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 :state) |
| 10 | (:import-from :str) | 10 | (:import-from :str) |
| 11 | (:import-from :ukkoclot/src/transport :do-call) | 11 | (:import-from :ukkoclot/src/transport :do-call :http-method) |
| 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) |
| 14 | 14 | ||
| @@ -21,6 +21,7 @@ | |||
| 21 | (defparameter +unique+ (gensym)) | 21 | (defparameter +unique+ (gensym)) |
| 22 | 22 | ||
| 23 | ;; TODO: Fix optional-and-key ! | 23 | ;; TODO: Fix optional-and-key ! |
| 24 | (-> make-param (symbol t &optional t &key (:skip-if-default boolean)) param) | ||
| 24 | (defun make-param (name type ; lint:suppress avoid-optional-and-key | 25 | (defun make-param (name type ; lint:suppress avoid-optional-and-key |
| 25 | &optional (default +unique+) | 26 | &optional (default +unique+) |
| 26 | &key (skip-if-default (not (eq default +unique+)))) | 27 | &key (skip-if-default (not (eq default +unique+)))) |
| @@ -32,26 +33,34 @@ | |||
| 32 | :default default | 33 | :default default |
| 33 | :skip-if-default skip-if-default))) | 34 | :skip-if-default skip-if-default))) |
| 34 | 35 | ||
| 36 | ;; TODO: list-of-params, list-of-param-specs | ||
| 37 | (-> parse-param-specs (list) list) | ||
| 35 | (defun parse-param-specs (param-specs) | 38 | (defun parse-param-specs (param-specs) |
| 36 | (iter (for param-spec in param-specs) | 39 | (iter (for param-spec in param-specs) |
| 37 | (collect (apply #'make-param param-spec)))) | 40 | (collect (apply #'make-param param-spec)))) |
| 38 | 41 | ||
| 42 | (-> path-from-name (symbol) string) | ||
| 39 | (defun path-from-name (name) | 43 | (defun path-from-name (name) |
| 40 | (let ((str (str:camel-case name))) | 44 | (let ((str (str:camel-case name))) |
| 41 | (if (str:ends-with-p "%" str :ignore-case nil) | 45 | (if (str:ends-with-p "%" str :ignore-case nil) |
| 42 | (take (- (length str) 1) str) | 46 | (take (- (length str) 1) str) |
| 43 | str))) | 47 | str))) |
| 44 | 48 | ||
| 49 | (-> emit-append-to-args (param symbol) list) | ||
| 45 | (defun emit-append-to-args (param args) | 50 | (defun emit-append-to-args (param args) |
| 46 | `(setf ,args (acons ',(param-name param) ,(param-name param) ,args))) | 51 | `(setf ,args (acons ',(param-name param) ,(param-name param) ,args))) |
| 47 | 52 | ||
| 53 | (-> emit-arg-type (param) list) | ||
| 48 | (defun emit-arg-type (param) | 54 | (defun emit-arg-type (param) |
| 49 | `(,(make-keyword (param-name param)) | 55 | `(,(make-keyword (param-name param)) |
| 50 | ,(param-type param))) | 56 | ,(param-type param))) |
| 51 | 57 | ||
| 58 | (-> emit-defun-arg (param) list) | ||
| 52 | (defun emit-defun-arg (param) | 59 | (defun emit-defun-arg (param) |
| 53 | `(,(param-name param) ,(param-default param))) | 60 | `(,(param-name param) ,(param-default param))) |
| 54 | 61 | ||
| 62 | ;; TODO: list-of-params | ||
| 63 | (-> emit-defun (symbol t list http-method) list) | ||
| 55 | (defun emit-defun (name return-type params method) | 64 | (defun emit-defun (name return-type params method) |
| 56 | (with-gensyms (args) | 65 | (with-gensyms (args) |
| 57 | `(defun ,name (&key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid | 66 | `(defun ,name (&key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid |
| @@ -65,11 +74,13 @@ | |||
| 65 | (emit-append-to-args param args)))) | 74 | (emit-append-to-args param args)))) |
| 66 | (do-call ,method ,(path-from-name name) ',return-type ,args))))) | 75 | (do-call ,method ,(path-from-name name) ',return-type ,args))))) |
| 67 | 76 | ||
| 77 | ;; TODO: list-of-params | ||
| 78 | (-> emit-ftype (symbol t list) list) | ||
| 68 | (defun emit-ftype (name return-type params) | 79 | (defun emit-ftype (name return-type params) |
| 69 | `(declaim (ftype (function (&key ,@(iter (for param in params) | 80 | `(-> ,name |
| 70 | (collect (emit-arg-type param)))) | 81 | (&key ,@(iter (for param in params) |
| 71 | ,return-type) | 82 | (collect (emit-arg-type param)))) |
| 72 | ,name)))) | 83 | ,return-type))) |
| 73 | 84 | ||
| 74 | (defmacro define-tg-method ((name type &optional (method :POST)) | 85 | (defmacro define-tg-method ((name type &optional (method :POST)) |
| 75 | &body param-specs) | 86 | &body param-specs) |
diff --git a/src/tg/send-animation.lisp b/src/tg/send-animation.lisp index 560b331..acddb21 100644 --- a/src/tg/send-animation.lisp +++ b/src/tg/send-animation.lisp | |||
| @@ -2,6 +2,7 @@ | |||
| 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 | (:documentation "sendAnimation Telegram method") |
| 5 | (:import-from :serapeum :->) | ||
| 5 | (:use | 6 | (:use |
| 6 | :c2cl | 7 | :c2cl |
| 7 | :ukkoclot/src/tg/force-reply | 8 | :ukkoclot/src/tg/force-reply |
| @@ -41,6 +42,14 @@ | |||
| 41 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) | 42 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) |
| 42 | 43 | ||
| 43 | ;; TODO: Some kind of caching for files? | 44 | ;; TODO: Some kind of caching for files? |
| 45 | (-> reply-animation (message | ||
| 46 | pathname | ||
| 47 | &key | ||
| 48 | (:allow-sending-without-reply boolean) | ||
| 49 | (:text (or string null)) | ||
| 50 | (:parse-mode (or parse-mode null)) | ||
| 51 | (:caption-above boolean)) | ||
| 52 | message) | ||
| 44 | (defun reply-animation (msg animation &key allow-sending-without-reply text parse-mode caption-above) | 53 | (defun reply-animation (msg animation &key allow-sending-without-reply text parse-mode caption-above) |
| 45 | "Shortcut to reply to a given MSG with an animation." | 54 | "Shortcut to reply to a given MSG with an animation." |
| 46 | (send-animation :chat-id (message-chat-id msg) | 55 | (send-animation :chat-id (message-chat-id msg) |
diff --git a/src/tg/send-message.lisp b/src/tg/send-message.lisp index befecbe..7c24f87 100644 --- a/src/tg/send-message.lisp +++ b/src/tg/send-message.lisp | |||
| @@ -2,6 +2,7 @@ | |||
| 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 | (:documentation "sendMessage Telegram method") |
| 5 | (:import-from :serapeum :->) | ||
| 5 | (:use | 6 | (:use |
| 6 | :c2cl | 7 | :c2cl |
| 7 | :ukkoclot/src/tg/force-reply | 8 | :ukkoclot/src/tg/force-reply |
| @@ -31,6 +32,11 @@ | |||
| 31 | (reply-parameters (or reply-parameters null) nil) | 32 | (reply-parameters (or reply-parameters null) nil) |
| 32 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) | 33 | (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) |
| 33 | 34 | ||
| 35 | (-> reply-message (message | ||
| 36 | string | ||
| 37 | &key | ||
| 38 | (:parse-mode (or parse-mode null)) | ||
| 39 | (:allow-sending-without-reply boolean))) | ||
| 34 | (defun reply-message (msg text &key parse-mode allow-sending-without-reply) | 40 | (defun reply-message (msg text &key parse-mode allow-sending-without-reply) |
| 35 | "Shortcut to reply to a given MSG." | 41 | "Shortcut to reply to a given MSG." |
| 36 | (send-message :chat-id (message-chat-id msg) | 42 | (send-message :chat-id (message-chat-id msg) |
diff --git a/src/tg/set-my-name.lisp b/src/tg/set-my-name.lisp index 2b3869a..f0b5c5f 100644 --- a/src/tg/set-my-name.lisp +++ b/src/tg/set-my-name.lisp | |||
| @@ -2,6 +2,7 @@ | |||
| 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 | (:documentation "setMyName Telegram method.") |
| 5 | (:import-from :serapeum :->) | ||
| 5 | (:use :c2cl :ukkoclot/src/tg/bot-name :ukkoclot/src/tg/get-my-name :ukkoclot/src/tg/method-macros) | 6 | (:use :c2cl :ukkoclot/src/tg/bot-name :ukkoclot/src/tg/get-my-name :ukkoclot/src/tg/method-macros) |
| 6 | (:export :set-my-name)) | 7 | (:export :set-my-name)) |
| 7 | (in-package :ukkoclot/src/tg/set-my-name) | 8 | (in-package :ukkoclot/src/tg/set-my-name) |
| @@ -10,6 +11,9 @@ | |||
| 10 | (name (or string null) nil) | 11 | (name (or string null) nil) |
| 11 | (language-code (or string null) nil)) | 12 | (language-code (or string null) nil)) |
| 12 | 13 | ||
| 14 | (-> set-my-name | ||
| 15 | (&key (:name (or string null)) (:language-code (or string null))) | ||
| 16 | boolean) | ||
| 13 | (defun set-my-name (&key (name nil) (language-code nil)) | 17 | (defun set-my-name (&key (name nil) (language-code nil)) |
| 14 | "setMyName Telegram method. | 18 | "setMyName Telegram method. |
| 15 | 19 | ||
diff --git a/src/tg/type-macros.lisp b/src/tg/type-macros.lisp index ea35f48..02437ec 100644 --- a/src/tg/type-macros.lisp +++ b/src/tg/type-macros.lisp | |||
| @@ -5,6 +5,7 @@ | |||
| 5 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :alexandria :make-keyword :symbolicate :with-gensyms) | 6 | (:import-from :alexandria :make-keyword :symbolicate :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 :->) | ||
| 8 | (:import-from :str) | 9 | (:import-from :str) |
| 9 | (:import-from :ukkoclot/src/serializing :parse-value) | 10 | (:import-from :ukkoclot/src/serializing :parse-value) |
| 10 | (:import-from :ukkoclot/src/hash-tables :gethash-lazy) | 11 | (:import-from :ukkoclot/src/hash-tables :gethash-lazy) |
| @@ -22,6 +23,7 @@ | |||
| 22 | (defparameter +unique+ (gensym)) | 23 | (defparameter +unique+ (gensym)) |
| 23 | 24 | ||
| 24 | ;; TODO: Fix optional-and-key ! | 25 | ;; TODO: Fix optional-and-key ! |
| 26 | (-> make-field (symbol t &optional t &key (:skip-if-default boolean)) field) | ||
| 25 | (defun make-field (name type ; lint:suppress avoid-optional-and-key | 27 | (defun make-field (name type ; lint:suppress avoid-optional-and-key |
| 26 | &optional (default +unique+) | 28 | &optional (default +unique+) |
| 27 | &key (skip-if-default (not (eq default +unique+)))) | 29 | &key (skip-if-default (not (eq default +unique+)))) |
| @@ -33,28 +35,36 @@ | |||
| 33 | :default default | 35 | :default default |
| 34 | :skip-if-default skip-if-default))) | 36 | :skip-if-default skip-if-default))) |
| 35 | 37 | ||
| 38 | (-> type-constructor (symbol) symbol) | ||
| 36 | (defun type-constructor (name) | 39 | (defun type-constructor (name) |
| 37 | (symbolicate "MAKE-" name)) | 40 | (symbolicate "MAKE-" name)) |
| 38 | 41 | ||
| 42 | (-> field-accessor (symbol field) symbol) | ||
| 39 | (defun field-accessor (name field) | 43 | (defun field-accessor (name field) |
| 40 | (symbolicate name "-" (field-name field))) | 44 | (symbolicate name "-" (field-name field))) |
| 41 | 45 | ||
| 46 | (-> field-hash-key (field) string) | ||
| 42 | (defun field-hash-key (field) | 47 | (defun field-hash-key (field) |
| 43 | (str:snake-case (field-name field))) | 48 | (str:snake-case (field-name field))) |
| 44 | 49 | ||
| 50 | (-> field-keyword (field) keyword) | ||
| 45 | (defun field-keyword (field) | 51 | (defun field-keyword (field) |
| 46 | (make-keyword (field-name field))) | 52 | (make-keyword (field-name field))) |
| 47 | 53 | ||
| 54 | ;; TODO: list-of-fields, list-of-field-specs | ||
| 55 | (-> parse-field-specs (list) list) | ||
| 48 | (defun parse-field-specs (field-specs) | 56 | (defun parse-field-specs (field-specs) |
| 49 | (iter (for field-spec in field-specs) | 57 | (iter (for field-spec in field-specs) |
| 50 | (collect (apply #'make-field field-spec)))) | 58 | (collect (apply #'make-field field-spec)))) |
| 51 | 59 | ||
| 52 | (defun emit-append-to-pprint-args (field value pprint-args) | 60 | (-> emit-coerced-field (field (or symbol list)) list) |
| 53 | `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args))) | ||
| 54 | |||
| 55 | (defun emit-coerced-field (field value) | 61 | (defun emit-coerced-field (field value) |
| 56 | `(list ,(field-hash-key field) ,value ',(field-type field))) | 62 | `(list ,(field-hash-key field) ,value ',(field-type field))) |
| 57 | 63 | ||
| 64 | ;; TODO: list-of-fields | ||
| 65 | (-> emit-collect-nondefault-fields | ||
| 66 | (symbol list symbol (function (field (or symbol list)) list)) | ||
| 67 | list) | ||
| 58 | (defun emit-collect-nondefault-fields (name fields obj collector) | 68 | (defun emit-collect-nondefault-fields (name fields obj collector) |
| 59 | (with-gensyms (value) | 69 | (with-gensyms (value) |
| 60 | (iter (for field in (reverse fields)) | 70 | (iter (for field in (reverse fields)) |
| @@ -65,12 +75,16 @@ | |||
| 65 | ,(funcall collector field value))) | 75 | ,(funcall collector field value))) |
| 66 | (funcall collector field (list (field-accessor name field) obj))))))) | 76 | (funcall collector field (list (field-accessor name field) obj))))))) |
| 67 | 77 | ||
| 78 | (-> emit-constructor-args (field) list) | ||
| 68 | (defun emit-constructor-args (field) | 79 | (defun emit-constructor-args (field) |
| 69 | `(,(field-keyword field) ,(field-name field))) | 80 | `(,(field-keyword field) ,(field-name field))) |
| 70 | 81 | ||
| 82 | (-> emit-gethash (field symbol) list) | ||
| 71 | (defun emit-gethash (field source) | 83 | (defun emit-gethash (field source) |
| 72 | `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field))) | 84 | `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field))) |
| 73 | 85 | ||
| 86 | ;; TODO: list-of-fields | ||
| 87 | (-> emit-jzon-coerced-fields (symbol list) list) | ||
| 74 | (defun emit-jzon-coerced-fields (name fields) | 88 | (defun emit-jzon-coerced-fields (name fields) |
| 75 | (with-gensyms (obj result) | 89 | (with-gensyms (obj result) |
| 76 | `(defmethod jzon:coerced-fields ((,obj ,name)) | 90 | `(defmethod jzon:coerced-fields ((,obj ,name)) |
| @@ -81,10 +95,13 @@ | |||
| 81 | `(push ,(emit-coerced-field field value) ,result))) | 95 | `(push ,(emit-coerced-field field value) ,result))) |
| 82 | ,result)))) | 96 | ,result)))) |
| 83 | 97 | ||
| 98 | (-> emit-let-gethash (field symbol) list) | ||
| 84 | (defun emit-let-gethash (field source) | 99 | (defun emit-let-gethash (field source) |
| 85 | `(,(field-name field) | 100 | `(,(field-name field) |
| 86 | (parse-value ',(field-type field) ,(emit-gethash field source)))) | 101 | (parse-value ',(field-type field) ,(emit-gethash field source)))) |
| 87 | 102 | ||
| 103 | ;; TODO: list-of-fields | ||
| 104 | (-> emit-parse-value (symbol list) list) | ||
| 88 | (defun emit-parse-value (name fields) | 105 | (defun emit-parse-value (name fields) |
| 89 | (with-gensyms (source type) | 106 | (with-gensyms (source type) |
| 90 | `(defmethod parse-value ((,type (eql ',name)) ,source) | 107 | `(defmethod parse-value ((,type (eql ',name)) ,source) |
| @@ -94,6 +111,8 @@ | |||
| 94 | ,@(iter (for field in fields) | 111 | ,@(iter (for field in fields) |
| 95 | (appending (emit-constructor-args field)))))))) | 112 | (appending (emit-constructor-args field)))))))) |
| 96 | 113 | ||
| 114 | ;; TODO: list-of-fields | ||
| 115 | (-> emit-printer (symbol symbol list) list) | ||
| 97 | (defun emit-printer (name printer-name fields) | 116 | (defun emit-printer (name printer-name fields) |
| 98 | (with-gensyms (depth obj pprint-args stream) | 117 | (with-gensyms (depth obj pprint-args stream) |
| 99 | `(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid | 118 | `(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid |
| @@ -105,11 +124,14 @@ | |||
| 105 | `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))) | 124 | `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))) |
| 106 | (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args))))) | 125 | (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args))))) |
| 107 | 126 | ||
| 127 | ;; TODO: list-of-fields | ||
| 128 | (-> emit-struct (symbol symbol list) list) | ||
| 108 | (defun emit-struct (name printer-name fields) | 129 | (defun emit-struct (name printer-name fields) |
| 109 | `(defstruct (,name (:print-function ,printer-name)) | 130 | `(defstruct (,name (:print-function ,printer-name)) |
| 110 | ,@(iter (for field in fields) | 131 | ,@(iter (for field in fields) |
| 111 | (collect (emit-struct-field field))))) | 132 | (collect (emit-struct-field field))))) |
| 112 | 133 | ||
| 134 | (-> emit-struct-field (field) list) | ||
| 113 | (defun emit-struct-field (field) | 135 | (defun emit-struct-field (field) |
| 114 | `(,(field-name field) ,(field-default field) :type ,(field-type field)))) | 136 | `(,(field-name field) ,(field-default field) :type ,(field-type field)))) |
| 115 | 137 | ||
diff --git a/src/tg/user.lisp b/src/tg/user.lisp index 0768d12..aefdeeb 100644 --- a/src/tg/user.lisp +++ b/src/tg/user.lisp | |||
| @@ -3,6 +3,8 @@ | |||
| 3 | (defpackage :ukkoclot/src/tg/user | 3 | (defpackage :ukkoclot/src/tg/user |
| 4 | (:documentation "User Telegram type") | 4 | (:documentation "User Telegram type") |
| 5 | (:use :c2cl :ukkoclot/src/tg/type-macros) | 5 | (:use :c2cl :ukkoclot/src/tg/type-macros) |
| 6 | (:import-from :serapeum :->) | ||
| 7 | (:import-from :ukkoclot/src/streams :with-format-like-stream) | ||
| 6 | (:import-from :ukkoclot/src/strings :escape-xml) | 8 | (:import-from :ukkoclot/src/strings :escape-xml) |
| 7 | (:export | 9 | (:export |
| 8 | #:user | 10 | #:user |
| @@ -39,26 +41,19 @@ | |||
| 39 | (supports-inline-queries boolean nil) | 41 | (supports-inline-queries boolean nil) |
| 40 | (can-connect-to-business boolean nil)) | 42 | (can-connect-to-business boolean nil)) |
| 41 | 43 | ||
| 42 | (defun user-format-name% (user out) | 44 | (-> user-format-name (user &optional (or stream boolean)) (or string null)) |
| 43 | "Format the USER's name in a nice way to stream OUT." | 45 | (defun user-format-name (user &optional out-spec) |
| 44 | (format out "<a href=\"tg://user?id=~A\"><i>" (user-id user)) | 46 | "Format the `user''s name in a nice way." |
| 45 | (escape-xml (user-first-name user) out) | 47 | (with-format-like-stream (out out-spec) |
| 46 | (when (user-last-name user) | 48 | (format out "<a href=\"tg://user?id=~A\"><i>" (user-id user)) |
| 47 | (write-char #\Space out) | 49 | (escape-xml (user-first-name user) out) |
| 48 | (escape-xml (user-last-name user) out)) | 50 | (when (user-last-name user) |
| 49 | (write-string "</i>" out) | 51 | (write-char #\Space out) |
| 52 | (escape-xml (user-last-name user) out)) | ||
| 53 | (write-string "</i>" out) | ||
| 50 | 54 | ||
| 51 | (when (user-username user) | 55 | (when (user-username user) |
| 52 | (write-string " @" out) | 56 | (write-string " @" out) |
| 53 | (escape-xml (user-username user) out)) | 57 | (escape-xml (user-username user) out)) |
| 54 | 58 | ||
| 55 | (format out "</a> [<code>~A</code>]" (user-id user))) | 59 | (format out "</a> [<code>~A</code>]" (user-id user)))) |
| 56 | |||
| 57 | (defun user-format-name (user &optional out) | ||
| 58 | "Format the USER's name in a nice way to stream OUT. | ||
| 59 | |||
| 60 | If OUT is `nil', return the formatted name as a string instead." | ||
| 61 | (if out | ||
| 62 | (user-format-name% user out) | ||
| 63 | (with-output-to-string (stream) | ||
| 64 | (user-format-name% user stream)))) | ||
diff --git a/src/transport.lisp b/src/transport.lisp index 6906e6d..12e09f4 100644 --- a/src/transport.lisp +++ b/src/transport.lisp | |||
| @@ -6,13 +6,20 @@ | |||
| 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 :serapeum :->) | ||
| 9 | (:import-from :state :base-uri) | 10 | (:import-from :state :base-uri) |
| 10 | (:import-from :ukkoclot/src/serializing :fixup-args :parse-value) | 11 | (:import-from :ukkoclot/src/serializing :fixup-args :parse-value) |
| 11 | (:local-nicknames | 12 | (:local-nicknames |
| 12 | (:jzon :com.inuoe.jzon)) | 13 | (:jzon :com.inuoe.jzon)) |
| 13 | (:export :do-call)) | 14 | (:export :do-call :http-method)) |
| 14 | (in-package :ukkoclot/src/transport) | 15 | (in-package :ukkoclot/src/transport) |
| 15 | 16 | ||
| 17 | ;; Yes I know there are more, these are all I care about though | ||
| 18 | (deftype http-method () | ||
| 19 | '(member :GET :POST)) | ||
| 20 | |||
| 21 | ;; TODO: Better type for the list, it's an alist of string to t | ||
| 22 | (-> req (string http-method list) (or string null)) | ||
| 16 | (defun req (uri method content) | 23 | (defun req (uri method content) |
| 17 | "Wrapper function for making a request." | 24 | "Wrapper function for making a request." |
| 18 | (let ((retrier (dex:retry-request 5 :interval 1)) | 25 | (let ((retrier (dex:retry-request 5 :interval 1)) |
| @@ -25,6 +32,8 @@ | |||
| 25 | (dex:http-request-failed (e) (funcall retrier e)) | 32 | (dex:http-request-failed (e) (funcall retrier e)) |
| 26 | (cl+ssl::ssl-error (e) (funcall retrier e))))) | 33 | (cl+ssl::ssl-error (e) (funcall retrier e))))) |
| 27 | 34 | ||
| 35 | ;; TODO: (alist string t) | ||
| 36 | (-> do-call% (http-method string t list) t) | ||
| 28 | (defun do-call% (method uri out-type args-encoded) | 37 | (defun do-call% (method uri out-type args-encoded) |
| 29 | "Internal function with the arguments already encoded. | 38 | "Internal function with the arguments already encoded. |
| 30 | 39 | ||
| @@ -47,6 +56,8 @@ See `do-call'." | |||
| 47 | (error "TG error ~A: ~A ~:A" | 56 | (error "TG error ~A: ~A ~:A" |
| 48 | error-code description parameters))))))) | 57 | error-code description parameters))))))) |
| 49 | 58 | ||
| 59 | ;; TODO: (alist t t) | ||
| 60 | (-> do-call (http-method string t list) t) | ||
| 50 | (defun do-call (method path out-type args) | 61 | (defun do-call (method path out-type args) |
| 51 | "Perform a HTTP call." | 62 | "Perform a HTTP call." |
| 52 | (let ((uri (concatenate 'string (base-uri) path)) | 63 | (let ((uri (concatenate 'string (base-uri) path)) |