[CORE] Webhooks

plugins/ledger.lisp

@@ -5,11 +5,8 @@
 (defvar *ledger/chat-journals* (make-hash-table))
 
 (defun ledger/get-hook-url (chat-id url)
-  (when *web-path*
-    (quri:render-uri
-     (quri:merge-uris (quri:uri (format nil "/hook/ledger/~A/~A/" chat-id
-                                        (token-hmac (format nil "~A~A" chat-id url))))
-                      (quri:uri *web-path*)))))
+  (declare (ignore url))
+  (get-webhook-url "ledger" chat-id (token-hmac (format nil "~A" chat-id))))
 
 (defun ledger/parse-uri (chat-id uri)
   (setf (gethash chat-id *ledger/chat-journals*)
@@ -44,11 +41,12 @@
         (destructuring-bind (journal . ut)
             (or (gethash chat-id *ledger/chat-journals*)
                 (ledger/parse-uri chat-id uri))
-          (send-response chat-id (format nil "Журнал с ~D записями, из ~A, обновлён ~A"
+          (send-response chat-id (format nil "Журнал с ~D записями, из ~A, обновлён ~A.~%Веб-хук: ~A"
                                          (length journal)
                                          (quri:render-uri (quri:make-uri :userinfo nil
                                                                          :defaults uri))
-                                         (ledger/format-time ut))))
+                                         (ledger/format-time ut)
+                                         (ledger/get-hook-url chat-id uri))))
         (send-response chat-id "Добавь урл журнала, /ledger <url>"))))
 
 (def-message-cmd-handler handler-ledger (:ledger)
@@ -74,3 +72,17 @@
   (cond
     ((null args) (ledger/handle-balance chat-id "assets"))
     (:otherwise (ledger/handle-balance chat-id (spaced args)))))
+
+(def-webhook-handler ledger/handle-webhook ("ledger")
+  (cond
+    ((= 2 (length paths))
+     (destructuring-bind (chat-id hmac) paths
+       (let ((true-hmac (token-hmac chat-id)))
+         (if (string= true-hmac hmac)
+             (secret/with (uri (list :ledger chat-id))
+               (if uri
+                   (progn (ledger/parse-uri (parse-integer chat-id) uri)
+                          "OK")
+                   "FAIL"))
+             "FAIL"))))
+    (:otherwise "FAIL")))

server.lisp

@@ -75,3 +75,23 @@
                    (hunchentoot:headers-in*)))
     (error (e) (log:error e)))
   "OK")
+
+(defmacro def-webhook-handler (name (&rest routes) &body body)
+  (let ((parts (gensym "parts")))
+    `(progn
+       (defun ,name (hook data headers)
+         (declare (ignorable data headers))
+         (let ((,parts (split-sequence:split-sequence #\/ hook)))
+           (when (member (car ,parts) (list ,@routes) :test #'equal)
+             (log:info ,parts)
+             (handler-case
+                 (let ((paths (rest ,parts)))
+                   ,@body)
+               (error (e) (log:error "~A" e))))))
+       (add-hook :webhook ',name))))
+
+(defun get-webhook-url (route &rest path)
+  (when *web-path*
+    (quri:render-uri
+     (quri:merge-uris (quri:uri (format nil "/hook/~A~{/~A~}" route path))
+                      (quri:uri *web-path*)))))

utils.lisp

@@ -297,7 +297,7 @@ is replaced with replacement."
   (let ((hmac (crypto:make-hmac (crypto:ascii-string-to-byte-array *telegram-token*) :sha256)))
     (crypto:update-hmac hmac (crypto:ascii-string-to-byte-array message))
     (base64:usb8-array-to-base64-string
-     (subseq (crypto:hmac-digest hmac) 0 hmac-length))))
+     (subseq (crypto:hmac-digest hmac) 0 hmac-length) :uri t)))
 
 (defun encode-callback-data (chat-id section data &optional (ttl 600) (hmac-length 12))
   (when (find #\: data)