diff options
Diffstat (limited to 'src/bot/impl.lisp')
| -rw-r--r-- | src/bot/impl.lisp | 61 |
1 files changed, 2 insertions, 59 deletions
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) |