[ledger] inline editor

bot.lisp

@@ -6,9 +6,12 @@
   (:import-from :chatikbot.telegram
                 :telegram-get-updates
                 :send-response)
-  (:export :handle-update))
+  (:export :handle-update
+           :*bot-user-id*
+           :on-next-message))
 (in-package :chatikbot.bot)
 
+(defvar *bot-user-id* nil "Bot user_id")
 (defvar *telegram-last-update* 0 "Telegram last update_id")
 
 ;; getUpdates handling
@@ -23,7 +26,7 @@
 (defun handle-update (update)
   (log:info update)
   (let ((update-id (aget "update_id" update))
-        (reply-to (aget "id" (aget "from" (aget "reply_to_message" (aget "message" update))))))
+        (reply-to (agets update "message" "reply_to_message" "from" "id")))
     (if (> update-id *telegram-last-update*)
         (progn
           (if (and reply-to (not (equal reply-to *bot-user-id*)))
@@ -49,3 +52,22 @@
          (var (read-from-string (car args)))
          (val (read-from-string (format nil "~{~A~^ ~}" (rest args)))))
     (send-response chat-id (format nil "OK, ~A" (set-setting var val)))))
+
+(defvar *chat-next-message-handlers* (make-hash-table) "Out-of-order chat message handler")
+(defmacro on-next-message (chat-id &body body)
+  `(setf (gethash ,chat-id *chat-next-message-handlers*)
+         (lambda (message)
+           (with-parsed-message message
+             ,@body))))
+
+(def-message-handler chat-next-message-handler (message 1000)
+  (let ((handler (gethash chat-id *chat-next-message-handlers*)))
+    (when handler
+      (unwind-protect
+           (handler-case (funcall handler message)
+             (error (e)
+               (log:error "~A" e)
+               (send-response chat-id
+                              (format nil "Ошибочка вышла~@[: ~A~]"
+                                      (when (member chat-id *admins*) e)))))
+        (remhash chat-id *chat-next-message-handlers*)))))

chatikbot.asd

@@ -32,6 +32,7 @@
                (:file "crypto")
                (:file "macros")
                (:file "bot")
+               (:file "inline")
                (:file "server")
                (:file "common")
                (:file "chatikbot")))

chatikbot.lisp

@@ -28,7 +28,8 @@
   (:import-from :chatikbot.macros
                 :defcron)
   (:import-from :chatikbot.bot
-                :process-updates)
+                :process-updates
+                :*bot-user-id*)
   (:import-from :chatikbot.server
                 :*web-path*
                 :*web-iface*
@@ -37,7 +38,6 @@
 
 (in-package :chatikbot)
 
-(defvar *bot-user-id* nil "Bot user_id")
 (defvar *plugins* nil "list of enabled plugins.")
 
 (defun plugins-db-init ()
@@ -105,7 +105,8 @@
 (defun start ()
   ;; Test telegram token
   (setf *bot-name* (concatenate 'string "@" (aget "username" (telegram-get-me)))
-        *bot-user-id* (parse-integer *telegram-token* :end (position #\: *telegram-token*)))
+        *bot-user-id* (parse-integer *telegram-token*
+                                     :end (position #\: *telegram-token*)))
 
   (cleanup)
 

common.lisp

@@ -7,7 +7,9 @@
         :chatikbot.crypto
         :chatikbot.secrets
         :chatikbot.server
-        :chatikbot.macros)
+        :chatikbot.macros
+        :chatikbot.bot
+        :chatikbot.inline)
   (:export :db-transaction
            :db-execute
            :db-select
@@ -113,6 +115,9 @@
            :raw-data
            :message
            :inline-message-id
+           :source-message
+           :source-message-id
+           :source-chat-id
            :def-callback-section-handler
            :data
            :section
@@ -122,5 +127,8 @@
            :error
            :raw-state
            :state
-           :defcron))
+           :defcron
+           :on-next-message
+           :get-inline-keyboard
+           :inline-button))
 (in-package :chatikbot.common)

crypto.lisp

@@ -18,6 +18,8 @@
      (subseq (crypto:hmac-digest hmac) 0 hmac-length) :uri t)))
 
 (defun encode-callback-data (chat-id section data &optional (ttl 600) (hmac-length 12))
+  (unless (stringp data)
+    (setf data (format nil "~A" data)))
   (when (find #\: data)
     (error "Bad data."))
   (let* ((message (format nil "~A:~A:~A:~A"

inline.lisp

@@ -0,0 +1,68 @@
+(in-package :cl-user)
+(defpackage chatikbot.inline
+  (:use :cl :chatikbot.utils :chatikbot.telegram :chatikbot.crypto
+        :chatikbot.macros)
+  (:export :get-inline-keyboard
+           :inline-button))
+(in-package :chatikbot.inline)
+
+(defstruct button callback created)
+(defparameter +max-id+ 2000000000 "Buttons store key range")
+(defparameter +max-tries+ 100 "Tries to find free store key")
+(defparameter +ttl+ (* 60 60 24 7) "Weekly TTL for buttons in store")
+
+(defvar *inline-buttons* (make-hash-table) "Hashtable storing button actions")
+(defvar *buttons-lock* (bt:make-recursive-lock "inline buttons lock"))
+
+(defun add-button (callback)
+  (bt:with-recursive-lock-held (*buttons-lock*)
+    (let ((id (loop for id = (random +max-id+) then (random +max-id+)
+                 for try from 1
+                 unless (gethash id *inline-buttons*)
+                 do (return id)
+                 when (> try +max-tries+)
+                 do (error "Can't get inline button id in ~A tries" try))))
+      (setf (gethash id *inline-buttons*)
+            (make-button :callback callback
+                         :created (get-universal-time)))
+      id)))
+
+(defun prune-buttons ()
+  (bt:with-recursive-lock-held (*buttons-lock*)
+    (let ((now (get-universal-time)))
+      (loop for id being the hash-keys in *inline-buttons* using (hash-value button)
+         when (> (- now (button-created button))
+                 +ttl+)
+         do (remhash id *inline-buttons*)))))
+
+(defmacro inline-button ((text) &body body)
+  `(cons ,text
+         (lambda (callback)
+           (with-parsed-callback callback
+             (handler-case (progn ,@body)
+               (error (e)
+                 (log:error "~A" e)
+                 (telegram-answer-callback-query
+                  query-id
+                  :text (format nil "Ошибочка вышла~@[: ~A~]"
+                                (when (member chat-id *admins*) e)))))))))
+
+(defun get-inline-keyboard (chat-id buttons)
+  (telegram-inline-keyboard-markup
+   (loop for row in buttons
+      when row
+      collect (loop for (text . callback) in row
+                 when text
+                 collect (list
+                          :text text
+                          :callback-data
+                          (encode-callback-data
+                           chat-id :inline (add-button callback) +ttl+))))))
+
+(def-callback-section-handler cb-handle-inline (:inline)
+  (let ((button (gethash (parse-integer data) *inline-buttons*)))
+    (if button
+        (funcall (button-callback button) callback)
+        (progn
+          (log:error "Can't find button id ~A" data)
+          (telegram-answer-callback-query query-id :text "Ошибка")))))

macros.lisp

@@ -2,9 +2,11 @@
 (defpackage chatikbot.macros
   (:use :cl :chatikbot.utils :chatikbot.telegram :chatikbot.crypto)
   (:export :def-db-init
+           :with-parsed-message
            :def-message-handler
            :def-message-cmd-handler
            :def-message-admin-cmd-handler
+           :with-parsed-callback
            :def-callback-handler
            :def-callback-section-handler
            :def-oauth-handler
@@ -18,20 +20,25 @@
                             (error (e) (log:error e)))
                           (values))))
 
-(defmacro def-message-handler (name (message) &body body)
+(defmacro with-parsed-message (message &body body)
+  `(let ((message-id (agets ,message "message_id"))
+         (from-id (agets ,message "from" "id"))
+         (chat-id (agets ,message "chat" "id"))
+         (text (agets ,message "text")))
+     (declare (ignorable message-id from-id chat-id text))
+     ,@body))
+
+(defmacro def-message-handler (name (message &optional prio) &body body)
   `(progn
      (defun ,name (,message)
-       (let ((message-id (aget "message_id" ,message))
-             (from-id (aget "id" (aget "from" ,message)))
-             (chat-id (aget "id" (aget "chat" ,message)))
-             (text (aget "text" ,message)))
-         (declare (ignorable message-id from-id chat-id text))
+       (with-parsed-message ,message
          (handler-case (progn ,@body)
            (error (e)
              (log:error "~A" e)
              (bot-send-message chat-id
                                (format nil "Ошибочка вышла~@[: ~A~]"
                                        (when (member chat-id *admins*) e)))))))
+     (when ,prio (setf (get ',name :prio) ,prio))
      (add-hook :update-message ',name)))
 
 (defmacro def-message-cmd-handler (name (&rest commands) &body body)
@@ -53,24 +60,30 @@
            ,@body
            t)))))
 
-(defmacro def-callback-handler (name (callback) &body body)
+(defmacro with-parsed-callback (callback &body body)
+  `(let* ((query-id (agets ,callback "id"))
+          (from (agets ,callback "from"))
+          (raw-data (agets ,callback "data"))
+          (source-message (agets ,callback "message"))
+          (inline-message-id (agets ,callback "inline_message_id"))
+          (from-id (agets from "id"))
+          (source-chat-id (agets source-message "chat" "id"))
+          (source-message-id (agets source-message "message_id")))
+     (declare (ignorable query-id from raw-data source-message inline-message-id
+                         from-id source-chat-id source-message-id))
+     ,@body))
+
+(defmacro def-callback-handler (name (callback &optional prio) &body body)
   `(progn
      (defun ,name (,callback)
-       (let* ((query-id (aget "id" ,callback))
-              (from (aget "from" ,callback))
-              (raw-data (aget "data" ,callback))
-              (message (aget "message" ,callback))
-              (inline-message-id (aget "inline_message_id" ,callback))
-              (from-id (aget "id" from))
-              (chat-id (aget "id" (aget "chat" message)))
-              (message-id (aget "message_id" message)))
-         (declare (ignorable query-id from raw-data message inline-message-id from-id chat-id message-id))
+       (with-parsed-callback ,callback
          (handler-case (progn ,@body)
            (error (e)
              (log:error "~A" e)
              (bot-send-message (or chat-id from-id)
                                (format nil "Ошибочка вышла~@[: ~A~]"
                                        (when (member chat-id *admins*) e)))))))
+     (when ,prio (setf (get ',name :prio) ,prio))
      (add-hook :update-callback-query ',name)))
 
 (defmacro def-callback-section-handler (name (&rest sections) &body body)
@@ -82,7 +95,7 @@
            ,@body
            t)))))
 
-(defmacro def-oauth-handler (name (code error state) &body body)
+(defmacro def-oauth-handler (name (code error state &optional prio) &body body)
   `(progn
      (defun ,name (,code ,error ,state)
        (declare (ignorable ,code ,error ,state))
@@ -90,6 +103,7 @@
          (error (e)
            (log:error "~A" e)
            (hunchentoot:redirect "/error"))))
+     (when ,prio (setf (get ',name :prio) ,prio))
      (add-hook :oauth ',name)))
 
 (defmacro def-oauth-section-handler (name (&rest sections) &body body)

plugins/finance.lisp

@@ -170,7 +170,7 @@
    (string-upcase label)))
 
 (def-message-cmd-handler handler-rates (:rates)
-  (let* ((symbols (or (when args (mapcar #'get-label-symbol args))
+  (let* ((symbols (or (mapcar #'get-label-symbol args)
                       (db/get-chat-symbols chat-id)
                       *default-symbols*))
          (last (db/get-last-finance symbols)))

plugins/huiza.lisp

@@ -52,10 +52,7 @@
     (when resp
       (send-response chat-id resp reply-id))))
 
-(defun handle-unknown-message (message)
-  (let ((chat-id (aget "id" (aget "chat" message)))
-        (text (aget "text" message)))
-    (log:info "handle-unknown-message" message)
-    (send-dont-understand chat-id (preprocess-input text))
-    t))
-(add-hook :update-message 'handle-unknown-message t)
+(def-message-handler huiza-handler (message -1000)
+  (log:info "handle-unknown-message" message)
+  (send-dont-understand chat-id (preprocess-input text))
+  t)

plugins/ledger.lisp

@@ -88,6 +88,19 @@
       (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
               year month day hour min sec))))
 
+(defun format-date (ut)
+  (multiple-value-bind (sec min hour day month year)
+      (decode-universal-time ut)
+    (declare (ignore sec min hour))
+    (format nil "~4,'0D-~2,'0D-~2,'0D"
+            year month day)))
+
+(defun get-year (ut)
+  (multiple-value-bind (sec min hour day month year)
+      (decode-universal-time ut)
+    (declare (ignore sec min hour day month))
+    year))
+
 (defun ledger/refresh-uri (chat-id uri)
   (setf (gethash chat-id *ledger/chat-journals*)
         (cons (pta-ledger:parse-journal (http-request uri))
@@ -147,6 +160,7 @@
     `(let ((,info (get-chat-journal-info ,chat-id)))
        (if ,info
            (destructuring-bind (,journal . ,updated) ,info
+             (declare (ignorable ,journal ,updated))
              ,@body)
            (send-response ,chat-id "Добавь журнал: uri - /ledger <url>; git - /ledger <remote> <path>")))))
 
@@ -192,22 +206,10 @@
 
 ;; New entries
 (defun format-entry (entry)
-  (format nil "```~%~A```" (pta-ledger:render entry)))
+  (let ((pta-ledger:*posting-length* 40))
+    (format nil "```~%~A```" (pta-ledger:render entry))))
 
-(defparameter +new-entry-actions+
-  `(("a" . "➕")
-    ("e" . "💲")
-    ("c" . "✖️")))
 
-(defun ledger/new-chat-entry (chat-id entry)
-  (bot-send-message chat-id (format-entry entry)
-                    :parse-mode "markdown"
-                    :reply-markup (telegram-inline-keyboard-markup
-                                   (list (loop for (a . l) in +new-entry-actions+
-                                            collect (list :text l
-                                                          :callback-data
-                                                          (encode-callback-data
-                                                           chat-id :ln a 86400)))))))
 (defun ledger/format-add-entry-message (from)
   (format nil "Ledger add from ~A ~A at ~A"
           (aget "first_name" from) (aget "last_name" from)
@@ -229,13 +231,170 @@
                (log:error "~A" e)
                "Не смог :(")))
           (:otherwise "Добавляю только в git журнал :("))
-      "Добавь git журнал.")))
-
-(def-callback-section-handler cb-handle-ln (:ln)
-  (case (keyify data)
-    (:a (telegram-answer-callback-query query-id :text "Добавляю...")
-        (telegram-send-message chat-id (ledger/process-add-entry
-                                        chat-id callback))
-        (telegram-edit-message-reply-markup nil :chat-id chat-id :message-id message-id))
-    (:e (telegram-answer-callback-query query-id :text "TBD"))
-    (:c (telegram-delete-message chat-id message-id))))
+        "Добавь git журнал.")))
+
+(defun ledger/new-chat-entry (chat-id entry)
+  (bot-send-message
+   chat-id (format-entry entry)
+   :parse-mode "markdown"
+   :reply-markup (keyboard/entry chat-id entry)))
+
+(defun entry-edit (chat-id message-id entry)
+  (telegram-edit-message-text
+   (format-entry entry)
+   :chat-id chat-id :message-id message-id
+   :parse-mode "markdown"
+   :reply-markup (keyboard/edit-entry chat-id entry)))
+
+(defun keyboard/entry (chat-id entry)
+  (get-inline-keyboard
+   chat-id
+   (list
+    (list (inline-button ("➕")
+            (telegram-answer-callback-query query-id :text "Добавляю...")
+            (telegram-send-message source-chat-id (ledger/process-add-entry
+                                                   source-chat-id callback))
+            (telegram-edit-message-reply-markup
+             nil :chat-id source-chat-id :message-id source-message-id))
+          (inline-button ("💲")
+            (entry-edit source-chat-id source-message-id entry))
+          (inline-button ("✖️")
+            (telegram-delete-message source-chat-id source-message-id))))))
+
+(defun def (str default)
+  (if (or (null str) (string= "" str)) default
+      str))
+
+(defun keyboard/edit-entry (chat-id entry)
+  (get-inline-keyboard
+   chat-id
+   (append
+    (list
+     (list (inline-button ((format-date (pta-ledger:entry-date entry)))
+             (bot-send-message chat-id "Введите дату"
+                               :reply-markup (telegram-force-reply))
+             (on-next-message chat-id
+               (let ((date (pta-ledger:parse-date text (get-year
+                                                        (pta-ledger:entry-date entry)))))
+                 (if date
+                     (progn
+                       (setf (pta-ledger:entry-date entry) date)
+                       (entry-edit chat-id source-message-id entry))
+                     (bot-send-message chat-id "Не разобрал")))))
+           (inline-button ((def (pta-ledger:entry-description entry) "Описание"))
+             (bot-send-message chat-id "Введите описание"
+                               :reply-markup (telegram-force-reply))
+             (on-next-message chat-id
+               (setf (pta-ledger:entry-description entry) text)
+               (entry-edit chat-id source-message-id entry)))
+           (inline-button ((def (pta-ledger:entry-comment entry) "Коммент"))
+             (bot-send-message chat-id "Введите комментарий"
+                               :reply-markup (telegram-force-reply))
+             (on-next-message chat-id
+               (setf (pta-ledger:entry-comment entry) text)
+               (entry-edit chat-id source-message-id entry)))))
+    (loop for posting in (pta-ledger:entry-postings entry)
+       collect
+         (let ((this-posting posting))
+           (list (inline-button ((pta-ledger:posting-account posting))
+                   (account-edit chat-id source-message-id entry this-posting
+                                 (pta-ledger:posting-account this-posting)))
+                 (inline-button ((def (pta-ledger:render
+                                       (pta-ledger:posting-amount posting))
+                                     "Сумма"))
+                   (bot-send-message chat-id "Введите сумму"
+                                     :reply-markup (telegram-force-reply))
+                   (on-next-message chat-id
+                     (let ((amount (pta-ledger:parse-amount text)))
+                       (setf (pta-ledger:posting-amount this-posting) amount)
+                       (entry-edit chat-id source-message-id entry)))))))
+    (list (list (inline-button ("Готово")
+                  (telegram-edit-message-reply-markup
+                   (keyboard/entry chat-id entry)
+                   :chat-id chat-id :message-id source-message-id)))))))
+
+(defun accounts/nav (account accounts &optional (offset 0) (count 5))
+  (let* ((len (1+ (length account)))
+         (sep-pos (position #\: account :from-end t))
+         (parent (when sep-pos (subseq account 0 sep-pos)))
+         (head (when account (concatenate 'string account ":")))
+         (descendants (remove-if #'(lambda (a)
+                                     (when head
+                                       (not (equal head
+                                                   (subseq a 0 (min (length a) len))))))
+                                 accounts)))
+    (if descendants
+        (let* ((children (sort (remove-duplicates
+                                (mapcar #'(lambda (d)
+                                            (subseq d 0 (or (position #\: d :start len)
+                                                            (length d))))
+                                        descendants)
+                                :test #'equal) #'string<))
+               (total (length children)))
+          (when (stringp offset)
+            (alexandria:when-let (off (position offset children :test #'equal))
+              (setf offset (max 0 (- off (round count 2))))))
+          (values account parent
+                  (mapcar
+                   #'(lambda (c)
+                       (let* ((needle (concatenate 'string c ":"))
+                              (n-l (length needle)))
+                         (cons c
+                               (not
+                                (find needle accounts :test #'equal
+                                      :key #'(lambda (a)
+                                               (subseq a 0 (min n-l (length a)))))))))
+                   (subseq children offset
+                           (min total (+ offset count))))
+                  (unless (zerop offset) (max 0 (- offset count)))
+                  (when (< (+ offset count) total) (+ offset count))))
+        (when parent (accounts/nav parent accounts account)))))
+
+(defun account-edit (chat-id message-id entry posting account &optional (offset 0))
+  (with-chat-journal (chat-id journal updated)
+    (let* ((accounts (pta-ledger:journal-accounts journal))
+           (nav-list (multiple-value-list
+                      (accounts/nav account accounts offset))))
+      (telegram-edit-message-reply-markup
+       (apply #'keyboard/account chat-id entry posting nav-list)
+       :chat-id chat-id :message-id message-id))))
+
+(defun keyboard/account (chat-id entry posting account parent children prev next)
+  (get-inline-keyboard
+   chat-id
+   (append
+    (list (list (when account
+                  (inline-button (account)
+                    (setf (pta-ledger:posting-account posting) account)
+                    (entry-edit chat-id source-message-id entry)))
+                (inline-button ("Ввести")
+                  (bot-send-message chat-id "Введите счёт"
+                                    :reply-markup (telegram-force-reply))
+                  (on-next-message chat-id
+                    (let ((account (pta-ledger:parse-account text)))
+                      (if account
+                          (progn
+                            (setf (pta-ledger:posting-account posting) account)
+                            (entry-edit chat-id source-message-id entry))
+                          (bot-send-message chat-id "Не разобрал")))))))
+    (loop for (acc . leaf) in children
+       collect (let ((this-account acc))
+                 (list (if leaf
+                           (inline-button (this-account)
+                             (setf (pta-ledger:posting-account posting) this-account)
+                             (entry-edit chat-id source-message-id entry))
+                           (inline-button ((format nil "~A ..." this-account))
+                             (account-edit chat-id source-message-id entry posting
+                                           this-account))))))
+    (list (list (when prev
+                  (inline-button ("<<")
+                    (account-edit chat-id source-message-id entry posting
+                                  account prev)))
+                (when (or parent account)
+                  (inline-button ((or parent "ACC"))
+                    (account-edit chat-id source-message-id entry posting
+                                  parent account)))
+                (when next
+                  (inline-button (">>")
+                    (account-edit chat-id source-message-id entry posting
+                                  account next))))))))

utils.lisp

@@ -62,6 +62,9 @@
            :raw-state
            :state
            :inline-message-id
+           :source-message
+           :source-message-id
+           :source-chat-id
            :hook
            :headers
            :paths))
@@ -83,12 +86,15 @@
       (unless (some #'try-handle hooks)
         (log:info "unhandled" event arguments)))))
 
-(defun add-hook (event hook &optional append)
+(defun add-hook (event hook)
   (let ((existing (gethash event *hooks*)))
     (unless (member hook existing)
       (setf (gethash event *hooks*)
-            (if append (append existing (list hook))
-                (cons hook existing))))))
+            (sort (cons hook existing) #'>
+                  :key #'(lambda (h)
+                           (etypecase h
+                             (symbol (get h :prio 0))
+                             (function 0))))))))
 
 (defun remove-hook (event hook)
   (setf (gethash event *hooks*)