diff options
| -rw-r--r-- | README.md | 2 | ||||
| -rw-r--r-- | src/bot/impl.lisp | 61 | ||||
| -rw-r--r-- | src/enum.lisp | 2 | ||||
| -rw-r--r-- | src/main.lisp | 3 | ||||
| -rw-r--r-- | src/serializing.lisp | 68 | ||||
| -rw-r--r-- | src/tg/type-macros.lisp | 2 |
6 files changed, 76 insertions, 62 deletions
| @@ -8,6 +8,8 @@ When running in a debuggy environment, consider | |||
| 8 | (log:config :debug) | 8 | (log:config :debug) |
| 9 | ``` | 9 | ``` |
| 10 | 10 | ||
| 11 | When connecting via remote SWANK, you might want to run `(log:config :sane2)`. | ||
| 12 | |||
| 11 | # Licensing | 13 | # Licensing |
| 12 | 14 | ||
| 13 | European Union Public Licence, version 1.2. | 15 | European Union Public Licence, version 1.2. |
diff --git a/src/bot/impl.lisp b/src/bot/impl.lisp index 652e2f7..93e63f5 100644 --- a/src/bot/impl.lisp +++ b/src/bot/impl.lisp | |||
| @@ -6,67 +6,16 @@ | |||
| 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 :ukkoclot/serializing :fixup-args :parse-value) | ||
| 9 | (:import-from :ukkoclot/strings :lisp->snake-case) | 10 | (:import-from :ukkoclot/strings :lisp->snake-case) |
| 10 | (:local-nicknames | 11 | (:local-nicknames |
| 11 | (:jzon :com.inuoe.jzon)) | 12 | (:jzon :com.inuoe.jzon)) |
| 12 | (:export | 13 | (:export |
| 13 | :bot :bot-p :make-bot :fixup-value :do-call :parse-value | 14 | :bot :bot-p :make-bot :do-call |
| 14 | 15 | ||
| 15 | :bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%)) | 16 | :bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%)) |
| 16 | (in-package :ukkoclot/bot/impl) | 17 | (in-package :ukkoclot/bot/impl) |
| 17 | 18 | ||
| 18 | (defgeneric parse-value (type json) | ||
| 19 | (:documentation "Parse value of TYPE from the parsed JSON") | ||
| 20 | (:method (type json) | ||
| 21 | (log:error "I don't know how to parse simple type ~A!" type) | ||
| 22 | (error "I don't know how to parse simple type ~A!" type)) | ||
| 23 | (:method ((type (eql 'boolean)) json) | ||
| 24 | (check-type json boolean) | ||
| 25 | json) | ||
| 26 | (:method ((type (eql 'integer)) json) | ||
| 27 | (check-type json integer) | ||
| 28 | json) | ||
| 29 | (:method ((type (eql 'null)) json) | ||
| 30 | (check-type json null) | ||
| 31 | json) | ||
| 32 | (:method ((type (eql 'string)) json) | ||
| 33 | (check-type json string) | ||
| 34 | json)) | ||
| 35 | |||
| 36 | (defun try-parse-value (type json) | ||
| 37 | (handler-case (values t (parse-value type json)) | ||
| 38 | (error () (values nil nil)))) | ||
| 39 | |||
| 40 | (defmethod parse-value ((type cons) json) | ||
| 41 | (cond ((and (eq (car type) 'array) | ||
| 42 | (null (cddr type))) | ||
| 43 | (when json | ||
| 44 | (let ((element-type (cadr type))) | ||
| 45 | (iter (for element in-vector json) | ||
| 46 | (collect (parse-value element-type element) result-type vector))))) | ||
| 47 | ((eq (car type) 'or) | ||
| 48 | (iter (for el-type in (cdr type)) | ||
| 49 | (multiple-value-bind (success res) (try-parse-value el-type json) | ||
| 50 | (when success | ||
| 51 | (return res))) | ||
| 52 | (finally | ||
| 53 | (error "Failed to parse ~S as ~A!" json type)))) | ||
| 54 | (t | ||
| 55 | (error "I don't know how to parse complex type ~A!" type)))) | ||
| 56 | |||
| 57 | (defgeneric fixup-value (value) | ||
| 58 | (:documentation "Fixup top-level VALUE before passing it onto telegram") | ||
| 59 | (:method (value) | ||
| 60 | (jzon:stringify value :pretty *print-pretty*)) | ||
| 61 | (:method ((value null)) | ||
| 62 | value) | ||
| 63 | (:method ((value number)) | ||
| 64 | value) | ||
| 65 | (:method ((value pathname)) | ||
| 66 | value) | ||
| 67 | (:method ((value string)) | ||
| 68 | value)) | ||
| 69 | |||
| 70 | (defstruct (bot (:constructor make-bot%)) | 19 | (defstruct (bot (:constructor make-bot%)) |
| 71 | (config (error "No value given for config") :read-only t) | 20 | (config (error "No value given for config") :read-only t) |
| 72 | (db (error "No value given for DB") :read-only t) | 21 | (db (error "No value given for DB") :read-only t) |
| @@ -81,12 +30,6 @@ | |||
| 81 | (config-bot-token config) "/"))) | 30 | (config-bot-token config) "/"))) |
| 82 | (make-bot% :config config :db db :base-uri base-uri))) | 31 | (make-bot% :config config :db db :base-uri base-uri))) |
| 83 | 32 | ||
| 84 | (defun fixup-args (args) | ||
| 85 | (iter (for (key . value) in args) | ||
| 86 | (collect | ||
| 87 | (cons (string-downcase (lisp->snake-case (symbol-name key))) | ||
| 88 | (fixup-value value))))) | ||
| 89 | |||
| 90 | (defun req (uri method content) | 33 | (defun req (uri method content) |
| 91 | (let ((retrier (dex:retry-request 5 :interval 1))) | 34 | (let ((retrier (dex:retry-request 5 :interval 1))) |
| 92 | (handler-case (dex:request uri :method method :content content) | 35 | (handler-case (dex:request uri :method method :content content) |
diff --git a/src/enum.lisp b/src/enum.lisp index e3ceb6b..8943a90 100644 --- a/src/enum.lisp +++ b/src/enum.lisp | |||
| @@ -2,7 +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/enum | 3 | (defpackage :ukkoclot/enum |
| 4 | (:use :c2cl :iterate) | 4 | (:use :c2cl :iterate) |
| 5 | (:import-from :ukkoclot/bot/impl :fixup-value :parse-value) | 5 | (:import-from :ukkoclot/serializing :fixup-value :parse-value) |
| 6 | (:import-from :string-case :string-case) | 6 | (:import-from :string-case :string-case) |
| 7 | (:local-nicknames | 7 | (:local-nicknames |
| 8 | (:jzon :com.inuoe.jzon)) | 8 | (:jzon :com.inuoe.jzon)) |
diff --git a/src/main.lisp b/src/main.lisp index a113ab0..d418b78 100644 --- a/src/main.lisp +++ b/src/main.lisp | |||
| @@ -6,8 +6,9 @@ | |||
| 6 | (:import-from :anaphora :acond :awhen :it) | 6 | (:import-from :anaphora :acond :awhen :it) |
| 7 | (:import-from :log) | 7 | (:import-from :log) |
| 8 | (:import-from :swank) | 8 | (:import-from :swank) |
| 9 | (:import-from :ukkoclot/bot :make-bot :bot-power-on :fixup-value) | 9 | (:import-from :ukkoclot/bot :make-bot :bot-power-on) |
| 10 | (:import-from :ukkoclot/db :with-db) | 10 | (:import-from :ukkoclot/db :with-db) |
| 11 | (:import-from :ukkoclot/serializing :fixup-value) | ||
| 11 | (:import-from :ukkoclot/strings :escape-xml :is-tg-whitespace-str :starts-with :starts-with-ignore-case) | 12 | (:import-from :ukkoclot/strings :escape-xml :is-tg-whitespace-str :starts-with :starts-with-ignore-case) |
| 12 | (:local-nicknames | 13 | (:local-nicknames |
| 13 | (:jzon :com.inuoe.jzon)) | 14 | (:jzon :com.inuoe.jzon)) |
diff --git a/src/serializing.lisp b/src/serializing.lisp new file mode 100644 index 0000000..7fafb3a --- /dev/null +++ b/src/serializing.lisp | |||
| @@ -0,0 +1,68 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | ||
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | ||
| 3 | (defpackage :ukkoclot/serializing | ||
| 4 | (:use :c2cl :iterate) | ||
| 5 | (:import-from :log) | ||
| 6 | (:import-from :ukkoclot/strings :lisp->snake-case) | ||
| 7 | (:local-nicknames | ||
| 8 | (:jzon :com.inuoe.jzon)) | ||
| 9 | (:export :fixup-args :fixup-value :parse-value :try-parse-value)) | ||
| 10 | (in-package :ukkoclot/serializing) | ||
| 11 | |||
| 12 | (defun fixup-args (args) | ||
| 13 | (iter (for (key . value) in args) | ||
| 14 | (collect | ||
| 15 | (cons (string-downcase (lisp->snake-case (symbol-name key))) | ||
| 16 | (fixup-value value))))) | ||
| 17 | |||
| 18 | (defgeneric fixup-value (value) | ||
| 19 | (:documentation "Fixup outgoing *top-level* `value' before passing it to telegram.") | ||
| 20 | (:method (value) | ||
| 21 | (jzon:stringify value :pretty *print-pretty*)) | ||
| 22 | (:method ((value null)) | ||
| 23 | value) | ||
| 24 | (:method ((value number)) | ||
| 25 | value) | ||
| 26 | (:method ((value pathname)) | ||
| 27 | value) | ||
| 28 | (:method ((value string)) | ||
| 29 | value)) | ||
| 30 | |||
| 31 | (defgeneric parse-value (type json) | ||
| 32 | (:documentation "Parse incoming value of `type' from the parsed `json'.") | ||
| 33 | (:method (type json) | ||
| 34 | (log:error "I don't know how to parse simple type ~A!" type) | ||
| 35 | (error "I don't know how to parse simple type ~A!" type)) | ||
| 36 | (:method ((type (eql 'boolean)) json) | ||
| 37 | (check-type json boolean) | ||
| 38 | json) | ||
| 39 | (:method ((type (eql 'integer)) json) | ||
| 40 | (check-type json integer) | ||
| 41 | json) | ||
| 42 | (:method ((type (eql 'null)) json) | ||
| 43 | (check-type json null) | ||
| 44 | json) | ||
| 45 | (:method ((type (eql 'string)) json) | ||
| 46 | (check-type json string) | ||
| 47 | json)) | ||
| 48 | |||
| 49 | (defmethod parse-value ((type cons) json) | ||
| 50 | (cond ((and (eq (car type) 'array) | ||
| 51 | (null (cddr type))) | ||
| 52 | (when json | ||
| 53 | (let ((element-type (cadr type))) | ||
| 54 | (iter (for element in-vector json) | ||
| 55 | (collect (parse-value element-type element) result-type vector))))) | ||
| 56 | ((eq (car type) 'or) | ||
| 57 | (iter (for el-type in (cdr type)) | ||
| 58 | (multiple-value-bind (success res) (try-parse-value el-type json) | ||
| 59 | (when success | ||
| 60 | (return res))) | ||
| 61 | (finally | ||
| 62 | (error "Failed to parse ~S as ~A!" json type)))) | ||
| 63 | (t | ||
| 64 | (error "I don't know how to parse complex type ~A!" type)))) | ||
| 65 | |||
| 66 | (defun try-parse-value (type json) | ||
| 67 | (handler-case (values t (parse-value type json)) | ||
| 68 | (error () (values nil nil)))) | ||
diff --git a/src/tg/type-macros.lisp b/src/tg/type-macros.lisp index 7380a6d..552c908 100644 --- a/src/tg/type-macros.lisp +++ b/src/tg/type-macros.lisp | |||
| @@ -2,7 +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/tg/type-macros | 3 | (defpackage :ukkoclot/tg/type-macros |
| 4 | (:use :c2cl :iterate) | 4 | (:use :c2cl :iterate) |
| 5 | (:import-from :ukkoclot/bot/impl :parse-value) | 5 | (:import-from :ukkoclot/serializing :parse-value) |
| 6 | (:import-from :ukkoclot/hash-tables :gethash-lazy) | 6 | (:import-from :ukkoclot/hash-tables :gethash-lazy) |
| 7 | (:import-from :ukkoclot/strings :lisp->snake-case) | 7 | (:import-from :ukkoclot/strings :lisp->snake-case) |
| 8 | (:local-nicknames | 8 | (:local-nicknames |