From fec434a4e2d0ff65510581e461d87a945d25759a Mon Sep 17 00:00:00 2001
From: Uko Kokņevičs
Date: Thu, 23 Oct 2025 10:17:00 +0300
Subject: Use serapeum's -> & defsubst
---
src/config.lisp | 14 ++++++++++++--
src/db.lisp | 34 +++++++++++++++++++++++-----------
src/enum.lisp | 13 ++++++++++++-
src/inline-bots.lisp | 12 ++++++++----
src/main.lisp | 41 +++++++++++++++++++++++++++++------------
src/rw-lock.lisp | 11 ++++++++++-
src/serializing.lisp | 6 +++++-
src/state.lisp | 19 +++++++++++++++----
src/strings.lisp | 36 ++++++++++++++++--------------------
src/tg/delete-message.lisp | 7 +++++--
src/tg/get-me.lisp | 4 ++++
src/tg/message-entity.lisp | 3 +++
src/tg/message.lisp | 13 +++++++------
src/tg/method-macros.lisp | 23 +++++++++++++++++------
src/tg/send-animation.lisp | 9 +++++++++
src/tg/send-message.lisp | 6 ++++++
src/tg/set-my-name.lisp | 4 ++++
src/tg/type-macros.lisp | 28 +++++++++++++++++++++++++---
src/tg/user.lisp | 37 ++++++++++++++++---------------------
src/transport.lisp | 13 ++++++++++++-
20 files changed, 238 insertions(+), 95 deletions(-)
(limited to 'src')
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 @@
(:nicknames :conf)
(:use :c2cl :iterate :ukkoclot/src/rw-lock)
(:import-from :alexandria :make-keyword)
+ (:import-from :serapeum :->)
(:export
#:*config*
#:config
@@ -31,36 +32,42 @@
(defvar *config* (make-config)
"Bot's configuration")
+(-> bot-name (&optional config) string)
(defun bot-name (&optional (config *config*))
"Get the desired name for the bot"
(with-slots (lock bot-name) config
(with-read-lock (lock)
bot-name)))
+(-> bot-token (&optional config) string)
(defun bot-token (&optional (config *config*))
"Get the API token for the bot"
(with-slots (lock bot-token) config
(with-read-lock (lock)
bot-token)))
+(-> db-path (&optional config) pathname)
(defun db-path (&optional (config *config*))
"Get the path to the bot's database"
(with-slots (lock db-path) config
(with-read-lock (lock)
- db-path)))
+ (pathname db-path))))
+(-> dev-group (&optional config) integer)
(defun dev-group (&optional (config *config*))
"Get the ID of the dev/testing group"
(with-slots (lock dev-group) config
(with-read-lock (lock)
dev-group)))
+(-> owner (&optional config) integer)
(defun owner (&optional (config *config*))
"Get the ID of the bot's owner"
(with-slots (lock owner) config
(with-read-lock (lock)
owner)))
+(-> load-config (pathname &optional config) config)
(defun load-config (filename &optional (config *config*))
"Load config from the given `filename'."
(prog1 config
@@ -71,6 +78,7 @@
(let ((name (intern (symbol-name kw-name) :ukkoclot/src/config)))
(setf (slot-value config name) value)))))))
+(-> serialize (config) list)
(defun serialize (config)
"Serializes the config to a plist."
(with-read-lock ((config-lock config))
@@ -81,10 +89,12 @@
(appending (list (make-keyword name)
(slot-value config name))))))))
+(-> print-default (pathname) (values &optional))
(defun print-default (filename)
"Prints the default config to the given `filename'."
(with-open-file (f filename :direction :output :if-exists :supersede)
(format f ";; lint:suppress in-package spdx-license-identifier~%")
(format f ";; Copy this file to config.lisp and modify it there~%")
(let ((data (serialize (make-config))))
- (format f "~<(~;~@{~(~W~) ~W~^ ~_~}~;)~:>~%" data))))
+ (format f "~<(~;~@{~(~W~) ~W~^ ~_~}~;)~:>~%" data)))
+ (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 @@
(defpackage :ukkoclot/src/db
(:use :c2cl :sqlite)
(:import-from :log)
- (:export :get-inline-bot-type :set-inline-bot-type :with-db))
+ (:import-from :serapeum :-> :defunion)
+ (:export :inline-bot-type :blacklisted :whitelisted :get-inline-bot-type :set-inline-bot-type :with-db))
(in-package :ukkoclot/src/db)
(defconstant +target-version+ 1
"Intended DB version")
+(deftype db ()
+ 'sqlite-handle)
+
(defmacro with-db ((name path) &body body)
`(let ((,name (connect ,path)))
(unwind-protect (progn (upgrade ,name) ,@body)
(disconnect ,name))))
+(defunion inline-bot-type
+ blacklisted
+ whitelisted)
+
+(-> get-inline-bot-type (db integer) (or inline-bot-type null))
(defun get-inline-bot-type (db id)
(let ((type-int (execute-single db "SELECT type FROM inline_bots WHERE id = ?" id)))
(when type-int
(integer->inline-bot-type type-int))))
+(-> set-inline-bot-type (db integer inline-bot-type) (values &optional))
(defun set-inline-bot-type (db id type)
(execute-non-query db
"INSERT OR REPLACE INTO inline_bots (id, type) VALUES (?, ?)"
id
(inline-bot-type->integer type)))
+(-> inline-bot-type->integer (inline-bot-type) integer)
(defun inline-bot-type->integer (type)
- (case type
- (:blacklisted 0)
- (:whitelisted 1)
- (otherwise (error "Unknown inline bot type ~S" type))))
+ (etypecase type
+ (blacklisted 0)
+ (whitelisted 1)))
+(-> integer->inline-bot-type (integer) inline-bot-type)
(defun integer->inline-bot-type (num)
- (case num
- (0 :blacklisted)
- (1 :whitelisted)
- (otherwise (error "Unknown inline bot type value ~S" num))))
+ (ecase num
+ (0 blacklisted)
+ (1 whitelisted)))
+(-> upgrade (db) (values &optional))
(defun upgrade (db)
(execute-non-query db "CREATE TABLE IF NOT EXISTS version(id INTEGER PRIMARY KEY, version INTEGER)")
(let ((current-ver (execute-single db "SELECT version FROM version WHERE id = 0")))
@@ -62,6 +73,7 @@
current-ver)))
(log:info "Database updating complete :)")))))
+(-> upgrade-step (db integer) (values &optional))
(defun upgrade-step (db new-version)
(case new-version
(1
@@ -73,8 +85,8 @@ CREATE TABLE inline_bots_enum (
(execute-non-query db "
INSERT INTO inline_bots_enum(id, value)
VALUES (?, 'blacklisted'), (?, 'whitelisted')"
- (inline-bot-type->integer :blacklisted)
- (inline-bot-type->integer :whitelisted))
+ (inline-bot-type->integer blacklisted)
+ (inline-bot-type->integer whitelisted))
(execute-non-query db "DROP TABLE IF EXISTS inline_bots")
(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 @@
(:documentation "Macro for generating an enum type.")
(:use :c2cl :iterate)
(:import-from :alexandria :with-gensyms)
- (:import-from :ukkoclot/src/serializing :fixup-value :parse-value)
+ (:import-from :serapeum :->)
(:import-from :string-case :string-case)
+ (:import-from :ukkoclot/src/serializing :fixup-value :parse-value)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export :define-enum))
@@ -14,36 +15,46 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct (field (:constructor make-field%)) name string)
+ (-> make-field (symbol string) field)
(defun make-field (name string)
"Better constructor for `field'."
(make-field% :name name :string string))
+ ;; TODO: list-of-fields, list-of-field-specs
+ (-> parse-field-specs (list) list)
(defun parse-field-specs (field-specs)
"Parse a list of field specs into a list of fields."
(iter (for field-spec in field-specs)
(collect (apply #'make-field field-spec))))
+ (-> emit-defconst (field) list)
(defun emit-defconst (field)
"Emit the `defconstant' statement for a specific field."
`(defconstant ,(field-name field) ',(field-name field)))
+ ;; TODO: list-of-fields
+ (-> emit-deftype (symbol list) list)
(defun emit-deftype (name fields)
"Emit the `deftype' statement for the enum."
`(deftype ,name ()
'(member ,@(iter (for field in fields) (collect (field-name field))))))
+ (-> emit-fixup-method (field) list)
(defun emit-fixup-method (field)
"Emit the `fixup-value' specialization for the enum."
(with-gensyms (arg)
`(defmethod fixup-value ((,arg (eql ',(field-name field))))
,(field-string field))))
+ (-> emit-jzon-write-method (field) list)
(defun emit-jzon-write-method (field)
"Emit the `json:write-value' specialization for the enum."
(with-gensyms (arg writer)
`(defmethod jzon:write-value ((,writer jzon:writer) (,arg (eql ',(field-name field))))
(jzon:write-value ,writer ,(field-string field)))))
+ ;; TODO: list-of-fields
+ (-> emit-parse-value (symbol list) list)
(defun emit-parse-value (name fields)
"Emit the `parse-value' specialization for the enum."
(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 @@
(:import-from :com.dieggsy.f-string :enable-f-strings)
(:import-from :conf)
(:import-from :log)
+ (:import-from :serapeum :->)
(:import-from :state)
(:local-nicknames (:db :ukkoclot/src/db))
(:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot))
@@ -13,27 +14,30 @@
(enable-f-strings)
+(-> blacklist-inline-bot (integer) (values &optional))
(defun blacklist-inline-bot (inline-bot-id)
"Blacklist the given bot.
No more messages about deleting its messages will be sent."
- (db:set-inline-bot-type (state:db) inline-bot-id :blacklisted))
+ (db:set-inline-bot-type (state:db) inline-bot-id db:blacklisted))
+(-> whitelist-inline-bot (integer) (values &optional))
(defun whitelist-inline-bot (inline-bot-id)
"Whitelist the given bot.
Its messages will no longer be deleted."
- (db:set-inline-bot-type (state:db) inline-bot-id :whitelisted))
+ (db:set-inline-bot-type (state:db) inline-bot-id db:whitelisted))
+(-> on-inline-bot (message user) boolean)
(defun on-inline-bot (msg via)
(let ((ty (db:get-inline-bot-type (state:db) (user-id via))))
- (or (eql ty :whitelisted)
+ (or (eql ty db:whitelisted)
(prog1 nil
(log:info "Deleting an unallowed inline bot message from ~A ~A"
(user-username via)
(user-id via))
(try-delete-message msg)
- (unless (eql ty :blacklisted)
+ (unless (eql ty db:blacklisted)
;; Not explicitly blacklisted, notify dev group
(let ((whitelist (make-inline-keyboard-button :text "Whitelist"
: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 @@
(:import-from :com.dieggsy.f-string :enable-f-strings)
(:import-from :conf)
(:import-from :log)
- (:import-from :serapeum :drop)
+ (:import-from :serapeum :-> :drop)
(:import-from :state :*state* :make-state)
(:import-from :str)
(:import-from :ukkoclot/src/db :with-db)
@@ -22,13 +22,13 @@
(defvar *in-prod* nil)
+(-> main () (values &optional))
(defun main ()
(unwind-protect
(progn
(conf:load-config #P"config.lisp")
(log:info "Starting up ~A" (conf:bot-name))
- (main-with-config)
- nil)
+ (main-with-config))
(log:info "Quitting!")))
(defmacro reporty ((evt) &body body)
@@ -38,6 +38,7 @@
(error (err) (report-error ,evt err))))
(t ,@body)))
+(-> main-with-config () (values &optional))
(defun main-with-config ()
(unwind-protect
(with-db (db (conf:db-path))
@@ -46,6 +47,7 @@
(wrapped-main))
(log:info "We're done!")))
+(-> wrapped-main () (values &optional))
(defun wrapped-main ()
(when *in-prod*
(send-message :chat-id (conf:dev-group) :text "Initializing..."))
@@ -65,8 +67,10 @@
(setf gup-offset (1+ (update-update-id update)))))))
;; One last getUpdates to make sure offset is stored on server
(get-updates :timeout 0 :limit 1 :offset gup-offset))
- (send-message :chat-id (conf:dev-group) :text "Shutting down..."))
+ (send-message :chat-id (conf:dev-group) :text "Shutting down...")
+ (values))
+(-> on-callback-query (callback-query) (values &optional))
(defun on-callback-query (cb)
(let ((data (callback-query-data cb)))
(cond ((and data
@@ -95,9 +99,10 @@
(log:info "Unrecognised callback query data: ~A" data)
(answer-callback-query :callback-query-id (callback-query-id cb)
:text "Unallowed callback query, don't press the button again"
- :show-alert t)))))
-
+ :show-alert t))))
+ (values))
+(-> on-message (message) (values &optional))
(defun on-message (msg)
(block nil
(when-let (inline-bot (message-via-bot msg))
@@ -110,8 +115,10 @@
(when-let (new-chat-members (message-new-chat-members msg))
(iter
(for new-chat-member in-vector new-chat-members)
- (on-new-member msg new-chat-member)))))
+ (on-new-member msg new-chat-member))))
+ (values))
+(-> on-new-member (message user) (values &optional))
(defun on-new-member (msg new-member)
(if (= (user-id new-member) (bot-id))
(reply-animation msg #P"blob/rule-11.mp4"
@@ -122,13 +129,16 @@
"! Be on your bestest behaviour now!!")
:parse-mode html
:caption-above t
- :allow-sending-without-reply t)))
+ :allow-sending-without-reply t))
+ (values))
+(-> is-bad-text (string) boolean)
(defun is-bad-text (text)
(declare (ignore text))
;; TODO:
nil)
+(-> on-text-message (message string) (values &optional))
(defun on-text-message (msg text)
(block nil
(when (is-bad-text text)
@@ -141,7 +151,7 @@
;; 5 current warns: Ban
;;
;; warn gets removed after a month of no warns
- (return))
+ (return (values)))
(when-let (entities (message-entities msg))
(iter
@@ -223,8 +233,10 @@
(write-char #\l s)
(write-char #\L s)))))
- (t nil))))
+ (t nil)))
+ (values))
+(-> simplify-cmd (string) (or string null))
(defun simplify-cmd (cmd)
(let ((at-idx (position #\@ cmd)))
(if (null at-idx)
@@ -235,6 +247,7 @@
(subseq cmd 1 at-idx)
nil)))))
+(-> on-text-command (message string string) (values &optional))
(defun on-text-command (msg text cmd)
(declare (ignore text))
(let ((simple-cmd (simplify-cmd cmd)))
@@ -264,14 +277,18 @@
(message-from msg)
(= (user-id (message-from msg)) (conf:owner)))
(setf (state:power-on) nil)
- (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t)))))
+ (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t))))
+ (values))
+(-> escape-xml-obj (t) string)
(defun escape-xml-obj (obj)
(escape-xml #f"{obj}"))
+(-> report-error (t t) (values &optional))
(defun report-error (evt err)
(log:error "While handling ~A: ~A" evt err)
(let ((msg #f"{(escape-xml-obj err)} while handling{;~%}{(escape-xml-obj evt)}"))
(send-message :chat-id (conf:dev-group)
:text msg
- :parse-mode html)))
+ :parse-mode html))
+ (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 @@
(:import-from :com.dieggsy.f-string :enable-f-strings)
(:import-from :sb-sys
:allow-with-interrupts :with-local-interrupts :without-interrupts)
+ (:import-from :serapeum :->)
(:export
#:rw-lock
#:rw-lock-p
@@ -36,12 +37,14 @@
(defvar *counter* 0)
+(-> gen-name () string)
(defun gen-name ()
"Generate a name for a rw-lock"
(format nil "Read-Write Lock ~A"
(with-lock-held (*counter-lock*)
(incf *counter*))))
+(-> make-rw-lock (&key (:name string)) rw-lock)
(defun make-rw-lock (&key (name (gen-name)))
(check-type name string)
(make-rw-lock%
@@ -49,6 +52,7 @@
:reader-cv (make-condition-variable :name #f"{name}'s internal reader-cv")
:writer-cv (make-condition-variable :name #f"{name}'s internal writer-cv")))
+(-> wakeup-waiters (rw-lock) (values &optional))
(defun wakeup-waiters (rw-lock)
;; NOTE: RW-LOCK-LOCK HAS TO BE TAKEN!
(declare (type rw-lock rw-lock))
@@ -57,8 +61,10 @@
((zerop waiting-readers) (condition-notify writer-cv))
((zerop waiting-writers) (condition-broadcast reader-cv))
(t (whichever (condition-notify writer-cv)
- (condition-broadcast reader-cv))))))
+ (condition-broadcast reader-cv)))))
+ (values))
+(-> acquire-read-lock (rw-lock &key (:wait boolean)) boolean)
(defun acquire-read-lock (rw-lock &key (wait t))
;; TODO: timeout
(check-type rw-lock rw-lock)
@@ -83,6 +89,7 @@
(decf waiting-readers)
(release-lock lock)))))))
+(-> release-read-lock (rw-lock) rw-lock)
(defun release-read-lock (rw-lock)
(check-type rw-lock rw-lock)
(with-slots (lock active-readers active-writer) rw-lock
@@ -107,6 +114,7 @@
(when ,lock-acquired
(release-read-lock ,lock-value)))))))
+(-> acquire-write-lock (rw-lock &key (:wait boolean)) boolean)
(defun acquire-write-lock (rw-lock &key (wait t))
;; TODO: timeout
(check-type rw-lock rw-lock)
@@ -131,6 +139,7 @@
(decf waiting-writers)
(release-lock lock)))))))
+(-> release-write-lock (rw-lock) rw-lock)
(defun release-write-lock (rw-lock)
(check-type rw-lock rw-lock)
(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 @@
(defpackage :ukkoclot/src/serializing
(:use :c2cl :iterate)
(:import-from :log)
+ (:import-from :serapeum :->)
(:import-from :str)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export :fixup-args :fixup-value :parse-value :try-parse-value))
(in-package :ukkoclot/src/serializing)
+;; TODO: Better types, input is an (alist t t) output is an (alist string t)
+(-> fixup-args (list) list)
(defun fixup-args (args)
(iter (for (key . value) in args)
(collect (cons (str:snake-case key) (fixup-value value)))))
(defgeneric fixup-value (value)
- (:documentation "Fixup outgoing *top-level* `value' before passing it to telegram.")
+ (:documentation "Fixup outgoing /top-level/ `value' before passing it to telegram.")
(:method (value)
(jzon:stringify value :pretty *print-pretty*))
(:method ((value null))
@@ -61,6 +64,7 @@
(t
(error "I don't know how to parse complex type ~A!" type))))
+(-> try-parse-value (t t) (values boolean t &optional))
(defun try-parse-value (type json)
(handler-case (values t (parse-value type json))
(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 @@
(:nicknames :state)
(:use :c2cl :ukkoclot/src/rw-lock)
(:import-from :com.dieggsy.f-string :enable-f-strings)
- (:import-from :conf :*config* :bot-token)
- (:import-from :sqlite :sqlite-handle)
+ (:import-from :conf :config :*config* :bot-token)
+ (:import-from :serapeum :->)
+ (:import-from :ukkoclot/src/db :db)
(:export
#:*state*
#:state
@@ -26,38 +27,44 @@
(defstruct (state (:constructor make-state%))
(lock (make-rw-lock :name "state's lock") :type rw-lock :read-only t)
- (db (error "No value given for DB") :type sqlite-handle :read-only t)
+ (db (error "No value given for DB") :type db :read-only t)
(base-uri (error "No value given for base-uri") :type string :read-only t)
(power-on t :type boolean)
(username% nil :type (or string null))
(id% nil :type (or integer null)))
+(-> make-state (db &optional config) state)
(defun make-state (db &optional (config *config*))
- (check-type db sqlite-handle)
+ (check-type db db)
(let ((base-uri #f"https://api.telegram.org/bot{(bot-token config)}/"))
(make-state% :db db :base-uri base-uri)))
(defvar *state* nil
"Bot's general state. You should initialise this with a value before doing anything fun.")
+(declaim (type (or state null) *state*))
+(-> db (&optional state) db)
(defun db (&optional (state *state*))
"Get the database handle of the bot."
(with-slots (lock db) state
(with-read-lock (lock)
db)))
+(-> base-uri (&optional state) string)
(defun base-uri (&optional (state *state*))
"Get the base URI of the bot."
(with-slots (lock base-uri) state
(with-read-lock (lock)
base-uri)))
+(-> power-on (&optional state) boolean)
(defun power-on (&optional (state *state*))
"Get whether the bot is running"
(with-slots (lock power-on) state
(with-read-lock (lock)
power-on)))
+(-> set-power-on (boolean &optional state) boolean)
(defun set-power-on (new-value &optional (state *state*))
"Set the value of the power-on"
(with-slots (lock power-on) state
@@ -67,12 +74,14 @@
(defsetf power-on (&optional (state '*state*)) (new-value)
`(set-power-on ,new-value ,state))
+(-> username% (&optional state) (or string null))
(defun username% (&optional (state *state*))
"Get the cached bot's username, you should probably use `ukkoclot/src/tg:bot-username' instead."
(with-slots (lock username%) state
(with-read-lock (lock)
username%)))
+(-> set-username% (string &optional state) string)
(defun set-username% (new-value &optional (state *state*))
(with-slots (lock username%) state
(with-write-lock (lock)
@@ -81,12 +90,14 @@
(defsetf username% (&optional (state '*state*)) (new-value)
`(set-username% ,new-value ,state))
+(-> id% (&optional state) (or integer null))
(defun id% (&optional (state *state*))
"Get the cached bot's ID, you should probably use `ukkoclot/src/tg:bot-id' instead."
(with-slots (lock id%) state
(with-read-lock (lock)
id%)))
+(-> set-id% (integer &optional state) integer)
(defun set-id% (new-value &optional (state *state*))
(with-slots (lock id%) state
(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 @@
(:documentation "String-oriented utilities.")
(:use :c2cl :iterate)
(:import-from :cl-unicode :general-category)
+ (:import-from :serapeum :->)
+ (:import-from :ukkoclot/src/streams :with-format-like-stream)
(:export
:escape-xml
:is-tg-whitespace
@@ -12,27 +14,20 @@
;; These are very inefficient but I don't care until I profile
-(defun escape-xml (str &optional out)
- "Escape special XML characters in the STR.
-
-OUT is the output stream or `nil' for outputting to a string."
- (if out
- (escape-xml% str out)
- (with-output-to-string (out)
- (escape-xml% str out))))
-
-(defun escape-xml% (str out)
- "See `escape-xml'.
-
-OUT is always the stream."
- (loop for ch across str do
- (case ch
- (#\< (write-string "<" out))
- (#\> (write-string ">" out))
- (#\& (write-string "&" out))
- (#\" (write-string """ out))
- (otherwise (write-char ch out)))))
+(-> escape-xml (string &optional (or stream boolean)) (or string null))
+(defun escape-xml (str &optional out-spec)
+ "Escape special XML characters in the STR."
+ (with-format-like-stream (out out-spec)
+ (iter
+ (for ch in-string str)
+ (case ch
+ (#\< (write-string "<" out))
+ (#\> (write-string ">" out))
+ (#\& (write-string "&" out))
+ (#\" (write-string """ out))
+ (otherwise (write-char ch out))))))
+(-> is-tg-whitespace (character) boolean)
(defun is-tg-whitespace (ch)
"Checks if CH on its own would be considered whitespace by telegram."
(let ((gc (general-category ch)))
@@ -42,6 +37,7 @@ OUT is always the stream."
(string= gc "Cc") ; Other, control
(= (char-code ch) #x2800)))) ; BRAILLE PATTERN BLANK
+(-> is-tg-whitespace-str (string) boolean)
(defun is-tg-whitespace-str (str)
"Checks if message containing just STR would be considered whitespace by telegram."
(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 @@
(defpackage :ukkoclot/src/tg/delete-message
(:documentation "deleteMessage Telegram method")
(:use :c2cl :ukkoclot/src/tg/message :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/send-animation)
+ (:import-from :serapeum :->)
(:export :delete-message :try-delete-message))
(in-package :ukkoclot/src/tg/delete-message)
@@ -10,6 +11,7 @@
(chat-id (or integer string))
(message-id integer))
+(-> try-delete-message (message) boolean)
(defun try-delete-message (msg)
"Attempt to delete the MSG, on failure reply with a GIF of the DO NOT cat."
(handler-case
@@ -17,6 +19,7 @@
:message-id (message-id msg))
(error ()
(handler-case
- (reply-animation msg #P"blob/do-not.mp4"
- :allow-sending-without-reply nil)
+ (prog1 nil
+ (reply-animation msg #P"blob/do-not.mp4"
+ :allow-sending-without-reply nil))
(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 @@
(defpackage :ukkoclot/src/tg/get-me
(:documentation "getMe Telegram method")
(:use :c2cl :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/user)
+ (:import-from :serapeum :->)
(:import-from :state)
(:export :bot-id :bot-username :get-me))
(in-package :ukkoclot/src/tg/get-me)
(define-tg-method (get-me% user :GET))
+(-> get-me () user)
(defun get-me ()
"getMe Telegram method"
(let ((me (get-me%)))
@@ -16,6 +18,7 @@
(setf (state:username%) (user-username me))
me))
+(-> bot-id () integer)
(defun bot-id ()
"Get the bot's ID, this memoizes the result"
(or (state:id%)
@@ -23,6 +26,7 @@
(get-me)
(state:id%))))
+(-> bot-username () string)
(defun bot-username ()
"Get the bot's username, this memoizes the result"
(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 @@
(defpackage :ukkoclot/src/tg/message-entity
(:documentation "MessageEntity Telegram type")
(:use :c2cl :iterate :ukkoclot/src/enum :ukkoclot/src/tg/type-macros :ukkoclot/src/tg/user)
+ (:import-from :serapeum :->)
(:export
#:message-entity-type
#:mention
@@ -72,6 +73,7 @@
(unless (= char-code-limit #x110000)
(error "Some UTF-16 fuckery assumes that system chars are UTF-32"))
+(-> utf16-width (character) (member 1 2))
(defun utf16-width (ch)
"Calculate the size of char in UTF-16 units."
(declare (type character ch))
@@ -79,6 +81,7 @@
1
2))
+(-> message-entity-extract (message-entity string) string)
(defun message-entity-extract (entity text)
"Extract the text corresponding to the ENTITY from the message text (in TEXT)."
(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 @@
:ukkoclot/src/tg/photo-size
:ukkoclot/src/tg/type-macros
:ukkoclot/src/tg/user)
+ (:import-from :serapeum :-> :defsubst)
(:export
#:message-chat-id
#:message-thread-id
@@ -163,17 +164,17 @@
;; (reply-markup (or inline-keyboard-markup null) nil)
) ; lint:suppress closing-parens-same-line whitespace-before-close-paren
-(declaim (inline message-id))
-(defun message-id (msg)
+(-> message-id (message) integer)
+(defsubst message-id (msg)
"Better named version of `message-message-id'."
(message-message-id msg))
-(declaim (inline message-chat-id))
-(defun message-chat-id (msg)
+(-> message-chat-id (message) integer)
+(defsubst message-chat-id (msg)
"Shortcut for (CHAT-ID (MESSAGE-CHAT MSG))."
(chat-id (message-chat msg)))
-(declaim (inline message-thread-id))
-(defun message-thread-id (msg)
+(-> message-thread-id (message) (or integer null))
+(defsubst message-thread-id (msg)
"Better named version of `message-message-thread-id'."
(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 @@
(:use :c2cl :iterate)
(:import-from :alexandria :make-keyword :with-gensyms)
(:import-from :com.dieggsy.f-string :enable-f-strings)
- (:import-from :serapeum :take)
+ (:import-from :serapeum :-> :take)
(:import-from :state)
(:import-from :str)
- (:import-from :ukkoclot/src/transport :do-call)
+ (:import-from :ukkoclot/src/transport :do-call :http-method)
(:export :define-tg-method))
(in-package :ukkoclot/src/tg/method-macros)
@@ -21,6 +21,7 @@
(defparameter +unique+ (gensym))
;; TODO: Fix optional-and-key !
+ (-> make-param (symbol t &optional t &key (:skip-if-default boolean)) param)
(defun make-param (name type ; lint:suppress avoid-optional-and-key
&optional (default +unique+)
&key (skip-if-default (not (eq default +unique+))))
@@ -32,26 +33,34 @@
:default default
:skip-if-default skip-if-default)))
+ ;; TODO: list-of-params, list-of-param-specs
+ (-> parse-param-specs (list) list)
(defun parse-param-specs (param-specs)
(iter (for param-spec in param-specs)
(collect (apply #'make-param param-spec))))
+ (-> path-from-name (symbol) string)
(defun path-from-name (name)
(let ((str (str:camel-case name)))
(if (str:ends-with-p "%" str :ignore-case nil)
(take (- (length str) 1) str)
str)))
+ (-> emit-append-to-args (param symbol) list)
(defun emit-append-to-args (param args)
`(setf ,args (acons ',(param-name param) ,(param-name param) ,args)))
+ (-> emit-arg-type (param) list)
(defun emit-arg-type (param)
`(,(make-keyword (param-name param))
,(param-type param)))
+ (-> emit-defun-arg (param) list)
(defun emit-defun-arg (param)
`(,(param-name param) ,(param-default param)))
+ ;; TODO: list-of-params
+ (-> emit-defun (symbol t list http-method) list)
(defun emit-defun (name return-type params method)
(with-gensyms (args)
`(defun ,name (&key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid
@@ -65,11 +74,13 @@
(emit-append-to-args param args))))
(do-call ,method ,(path-from-name name) ',return-type ,args)))))
+ ;; TODO: list-of-params
+ (-> emit-ftype (symbol t list) list)
(defun emit-ftype (name return-type params)
- `(declaim (ftype (function (&key ,@(iter (for param in params)
- (collect (emit-arg-type param))))
- ,return-type)
- ,name))))
+ `(-> ,name
+ (&key ,@(iter (for param in params)
+ (collect (emit-arg-type param))))
+ ,return-type)))
(defmacro define-tg-method ((name type &optional (method :POST))
&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 @@
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs
(defpackage :ukkoclot/src/tg/send-animation
(:documentation "sendAnimation Telegram method")
+ (:import-from :serapeum :->)
(:use
:c2cl
:ukkoclot/src/tg/force-reply
@@ -41,6 +42,14 @@
(reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil))
;; TODO: Some kind of caching for files?
+(-> reply-animation (message
+ pathname
+ &key
+ (:allow-sending-without-reply boolean)
+ (:text (or string null))
+ (:parse-mode (or parse-mode null))
+ (:caption-above boolean))
+ message)
(defun reply-animation (msg animation &key allow-sending-without-reply text parse-mode caption-above)
"Shortcut to reply to a given MSG with an animation."
(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 @@
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs
(defpackage :ukkoclot/src/tg/send-message
(:documentation "sendMessage Telegram method")
+ (:import-from :serapeum :->)
(:use
:c2cl
:ukkoclot/src/tg/force-reply
@@ -31,6 +32,11 @@
(reply-parameters (or reply-parameters null) nil)
(reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil))
+(-> reply-message (message
+ string
+ &key
+ (:parse-mode (or parse-mode null))
+ (:allow-sending-without-reply boolean)))
(defun reply-message (msg text &key parse-mode allow-sending-without-reply)
"Shortcut to reply to a given MSG."
(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 @@
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs
(defpackage :ukkoclot/src/tg/set-my-name
(:documentation "setMyName Telegram method.")
+ (:import-from :serapeum :->)
(:use :c2cl :ukkoclot/src/tg/bot-name :ukkoclot/src/tg/get-my-name :ukkoclot/src/tg/method-macros)
(:export :set-my-name))
(in-package :ukkoclot/src/tg/set-my-name)
@@ -10,6 +11,9 @@
(name (or string null) nil)
(language-code (or string null) nil))
+(-> set-my-name
+ (&key (:name (or string null)) (:language-code (or string null)))
+ boolean)
(defun set-my-name (&key (name nil) (language-code nil))
"setMyName Telegram method.
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 @@
(:use :c2cl :iterate)
(:import-from :alexandria :make-keyword :symbolicate :with-gensyms)
(:import-from :com.dieggsy.f-string :enable-f-strings)
+ (:import-from :serapeum :->)
(:import-from :str)
(:import-from :ukkoclot/src/serializing :parse-value)
(:import-from :ukkoclot/src/hash-tables :gethash-lazy)
@@ -22,6 +23,7 @@
(defparameter +unique+ (gensym))
;; TODO: Fix optional-and-key !
+ (-> make-field (symbol t &optional t &key (:skip-if-default boolean)) field)
(defun make-field (name type ; lint:suppress avoid-optional-and-key
&optional (default +unique+)
&key (skip-if-default (not (eq default +unique+))))
@@ -33,28 +35,36 @@
:default default
:skip-if-default skip-if-default)))
+ (-> type-constructor (symbol) symbol)
(defun type-constructor (name)
(symbolicate "MAKE-" name))
+ (-> field-accessor (symbol field) symbol)
(defun field-accessor (name field)
(symbolicate name "-" (field-name field)))
+ (-> field-hash-key (field) string)
(defun field-hash-key (field)
(str:snake-case (field-name field)))
+ (-> field-keyword (field) keyword)
(defun field-keyword (field)
(make-keyword (field-name field)))
+ ;; TODO: list-of-fields, list-of-field-specs
+ (-> parse-field-specs (list) list)
(defun parse-field-specs (field-specs)
(iter (for field-spec in field-specs)
(collect (apply #'make-field field-spec))))
- (defun emit-append-to-pprint-args (field value pprint-args)
- `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))
-
+ (-> emit-coerced-field (field (or symbol list)) list)
(defun emit-coerced-field (field value)
`(list ,(field-hash-key field) ,value ',(field-type field)))
+ ;; TODO: list-of-fields
+ (-> emit-collect-nondefault-fields
+ (symbol list symbol (function (field (or symbol list)) list))
+ list)
(defun emit-collect-nondefault-fields (name fields obj collector)
(with-gensyms (value)
(iter (for field in (reverse fields))
@@ -65,12 +75,16 @@
,(funcall collector field value)))
(funcall collector field (list (field-accessor name field) obj)))))))
+ (-> emit-constructor-args (field) list)
(defun emit-constructor-args (field)
`(,(field-keyword field) ,(field-name field)))
+ (-> emit-gethash (field symbol) list)
(defun emit-gethash (field source)
`(gethash-lazy ,(field-hash-key field) ,source ,(field-default field)))
+ ;; TODO: list-of-fields
+ (-> emit-jzon-coerced-fields (symbol list) list)
(defun emit-jzon-coerced-fields (name fields)
(with-gensyms (obj result)
`(defmethod jzon:coerced-fields ((,obj ,name))
@@ -81,10 +95,13 @@
`(push ,(emit-coerced-field field value) ,result)))
,result))))
+ (-> emit-let-gethash (field symbol) list)
(defun emit-let-gethash (field source)
`(,(field-name field)
(parse-value ',(field-type field) ,(emit-gethash field source))))
+ ;; TODO: list-of-fields
+ (-> emit-parse-value (symbol list) list)
(defun emit-parse-value (name fields)
(with-gensyms (source type)
`(defmethod parse-value ((,type (eql ',name)) ,source)
@@ -94,6 +111,8 @@
,@(iter (for field in fields)
(appending (emit-constructor-args field))))))))
+ ;; TODO: list-of-fields
+ (-> emit-printer (symbol symbol list) list)
(defun emit-printer (name printer-name fields)
(with-gensyms (depth obj pprint-args stream)
`(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid
@@ -105,11 +124,14 @@
`(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args))))
(format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))))
+ ;; TODO: list-of-fields
+ (-> emit-struct (symbol symbol list) list)
(defun emit-struct (name printer-name fields)
`(defstruct (,name (:print-function ,printer-name))
,@(iter (for field in fields)
(collect (emit-struct-field field)))))
+ (-> emit-struct-field (field) list)
(defun emit-struct-field (field)
`(,(field-name field) ,(field-default field) :type ,(field-type field))))
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 @@
(defpackage :ukkoclot/src/tg/user
(:documentation "User Telegram type")
(:use :c2cl :ukkoclot/src/tg/type-macros)
+ (:import-from :serapeum :->)
+ (:import-from :ukkoclot/src/streams :with-format-like-stream)
(:import-from :ukkoclot/src/strings :escape-xml)
(:export
#:user
@@ -39,26 +41,19 @@
(supports-inline-queries boolean nil)
(can-connect-to-business boolean nil))
-(defun user-format-name% (user out)
- "Format the USER's name in a nice way to stream OUT."
- (format out "" (user-id user))
- (escape-xml (user-first-name user) out)
- (when (user-last-name user)
- (write-char #\Space out)
- (escape-xml (user-last-name user) out))
- (write-string "" out)
+(-> user-format-name (user &optional (or stream boolean)) (or string null))
+(defun user-format-name (user &optional out-spec)
+ "Format the `user''s name in a nice way."
+ (with-format-like-stream (out out-spec)
+ (format out "" (user-id user))
+ (escape-xml (user-first-name user) out)
+ (when (user-last-name user)
+ (write-char #\Space out)
+ (escape-xml (user-last-name user) out))
+ (write-string "" out)
- (when (user-username user)
- (write-string " @" out)
- (escape-xml (user-username user) out))
+ (when (user-username user)
+ (write-string " @" out)
+ (escape-xml (user-username user) out))
- (format out " [~A]" (user-id user)))
-
-(defun user-format-name (user &optional out)
- "Format the USER's name in a nice way to stream OUT.
-
-If OUT is `nil', return the formatted name as a string instead."
- (if out
- (user-format-name% user out)
- (with-output-to-string (stream)
- (user-format-name% user stream))))
+ (format out " [~A]" (user-id user))))
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 @@
(:import-from :cl+ssl)
(:import-from :dex)
(:import-from :log)
+ (:import-from :serapeum :->)
(:import-from :state :base-uri)
(:import-from :ukkoclot/src/serializing :fixup-args :parse-value)
(:local-nicknames
(:jzon :com.inuoe.jzon))
- (:export :do-call))
+ (:export :do-call :http-method))
(in-package :ukkoclot/src/transport)
+;; Yes I know there are more, these are all I care about though
+(deftype http-method ()
+ '(member :GET :POST))
+
+;; TODO: Better type for the list, it's an alist of string to t
+(-> req (string http-method list) (or string null))
(defun req (uri method content)
"Wrapper function for making a request."
(let ((retrier (dex:retry-request 5 :interval 1))
@@ -25,6 +32,8 @@
(dex:http-request-failed (e) (funcall retrier e))
(cl+ssl::ssl-error (e) (funcall retrier e)))))
+;; TODO: (alist string t)
+(-> do-call% (http-method string t list) t)
(defun do-call% (method uri out-type args-encoded)
"Internal function with the arguments already encoded.
@@ -47,6 +56,8 @@ See `do-call'."
(error "TG error ~A: ~A ~:A"
error-code description parameters)))))))
+;; TODO: (alist t t)
+(-> do-call (http-method string t list) t)
(defun do-call (method path out-type args)
"Perform a HTTP call."
(let ((uri (concatenate 'string (base-uri) path))
--
cgit v1.2.3