From b4c1f66e1631f40d8a7d0f80523470677a91381f Mon Sep 17 00:00:00 2001
From: Uko Kokņevičs
Date: Fri, 10 Oct 2025 12:30:46 +0300
Subject: Bunch of changes

- Animations
- Rewrite of serialization deserialization
- Bunch of new TG types
---
 src/bot/impl.lisp | 91 +++++++++++++++++++++++++++++++++----------------------
 1 file changed, 54 insertions(+), 37 deletions(-)

(limited to 'src/bot/impl.lisp')

diff --git a/src/bot/impl.lisp b/src/bot/impl.lisp
index b57e2d3..57a9572 100644
--- a/src/bot/impl.lisp
+++ b/src/bot/impl.lisp
@@ -8,41 +8,62 @@
   (:local-nicknames
    (:jzon :com.inuoe.jzon))
   (:export
-   :arg-encode :bot :bot-p :make-bot :do-call
+   :bot :bot-p :make-bot :fixup-value :do-call :parse-value
 
    :bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%))
 (in-package :ukkoclot/bot/impl)
 
-(defgeneric will-arg-encode (object)
-  (:documentation "Whether the OBJECT has any transformation done to it by arg-encode")
-  (:method (obj)
-    nil)
-  (:method ((obj cons))
-    (or (will-arg-encode (car obj))
-        (will-arg-encode (cdr obj)))))
+(defgeneric parse-value (type json)
+  (:documentation "Parse value of TYPE from the parsed JSON")
+  (:method (type json)
+    (log-error "I don't know how to parse simple type ~A!" type)
+    (error "I don't know how to parse simple type ~A!" type))
+  (:method ((type (eql 'boolean)) json)
+    (check-type json boolean)
+    json)
+  (:method ((type (eql 'integer)) json)
+    (check-type json integer)
+    json)
+  (:method ((type (eql 'null)) json)
+    (check-type json null)
+    json)
+  (:method ((type (eql 'string)) json)
+    (check-type json string)
+    json))
 
-(defgeneric arg-encode (object)
-  (:documentation "Encode the OBJECT to a form that our HTTP code is happy about.")
-  (:method (obj)
-    obj)
-  (:method ((obj cons))
-    (if (not (will-arg-encode obj))
-        obj
-        (cons (arg-encode (car obj))
-              (arg-encode (cdr obj))))))
+(defun try-parse-value (type json)
+  (handler-case (values t (parse-value type json))
+    (error () (values nil nil))))
 
-(defgeneric fixup-arg (value)
-  (:documentation "Make sure Telegram & QURI & whatever like the arg")
+(defmethod parse-value ((type cons) json)
+  (cond ((and (eq (car type) 'array)
+              (null (cddr type)))
+         (when json
+           (let ((element-type (cadr type)))
+             (iter (for element in-vector json)
+               (collect (parse-value element-type element) result-type vector)))))
+        ((eq (car type) 'or)
+         (iter (for el-type in (cdr type))
+           (multiple-value-bind (success res) (try-parse-value el-type json)
+             (when success
+               (return res)))
+           (finally
+            (error "Failed to parse ~S as ~A!" json type))))
+        (t
+         (error "I don't know how to parse complex type ~A!" type))))
+
+(defgeneric fixup-value (value)
+  (:documentation "Fixup top-level VALUE before passing it onto telegram")
   (:method (value)
-    (error "Unsupported argument type ~S (~S)" (class-name (class-of value)) value))
+    (jzon:stringify value))
   (:method ((value null))
     value)
   (:method ((value number))
     value)
-  (:method ((value string))
+  (:method ((value pathname))
     value)
-  (:method ((value hash-table))
-    (jzon:stringify value)))
+  (:method ((value string))
+    value))
 
 (defstruct (bot (:constructor make-bot%))
   (config (error "No value given for config") :read-only t)
@@ -58,39 +79,35 @@
                                (config-bot-token config) "/")))
     (make-bot% :config config :db db :base-uri base-uri)))
 
-(defun args-plist->alist (args-plist)
-  (iter (for (old-key value) on args-plist by #'cddr)
+(defun fixup-args (args)
+  (iter (for (key . value) in args)
     (collect
-        (let ((new-key (string-downcase (lisp->snake-case (symbol-name old-key)))))
-          (cons new-key value)))))
-
-(defun fixup-args (args-alist)
-  (iter (for (name . value) in args-alist)
-    (collecting (cons name (fixup-arg (arg-encode value))))))
+        (cons (string-downcase (lisp->snake-case (symbol-name key)))
+              (fixup-value value)))))
 
 (defun req (uri method content)
   ;; We deal with this manually
   (handler-bind ((dex:http-request-too-many-requests #'dex:ignore-and-continue))
     (dex:request uri :method method :content content)))
 
-(defun do-call% (bot method uri mapfn args-encoded)
+(defun do-call% (bot method uri type args-encoded)
   (let ((body (req uri method args-encoded)))
     (let ((hash (jzon:parse body)))
       (acond
-        ((gethash "ok" hash) (funcall mapfn (gethash "result" hash)))
+        ((gethash "ok" hash) (parse-value type (gethash "result" hash)))
         ((aand (gethash "parameters" hash)
                (gethash "retry_after" it))
          (log-info "Should sleep for ~A seconds" it)
          (sleep it)
          (log-info "Good morning!")
-         (do-call% bot method uri mapfn args-encoded))
+         (do-call% bot method uri type args-encoded))
         (t (error "TG error ~A: ~A ~:A"
                   (gethash "error_code" hash)
                   (gethash "description" hash)
                   (gethash "parameters" hash)))))))
 
-(defun do-call (bot method path mapfn args-plist)
+(defun do-call (bot method path type args)
   (let ((uri (concatenate 'string (bot-base-uri bot) path))
-        (args-encoded (fixup-args (args-plist->alist args-plist))))
+        (args-encoded (fixup-args args)))
     (log-debug "~A .../~A ~S" method path args-encoded)
-    (do-call% bot method uri mapfn args-encoded)))
+    (do-call% bot method uri type args-encoded)))
-- 
cgit v1.2.3