chatikbot/plugins/saver.lisp

(in-package #:chatikbot)

(defsetting *saver-notify-hour* 11 "Notify with upcoming payments and saves at this time")

(defstruct saver/payment name amount schedule started)

(defun saver/parse-schedule (schedule)
  (labels ((parse (text &optional def-min def-max)
             (let ((dash-pos (position #\- text))
                   (star-pos (position #\* text))
                   (slash-pos (position #\/ text)))
               (if (or dash-pos star-pos slash-pos)
                   (let ((min (if star-pos def-min
                                  (when dash-pos (parse-integer text :end dash-pos))))
                         (max (if star-pos def-max
                                  (when dash-pos (parse-integer text :start (1+ dash-pos) :end slash-pos))))
                         (step (or (when slash-pos (parse-integer text :start (1+ slash-pos))) 1)))
                     (list nil min max step))
                   (list (sort (mapcar #'parse-integer (split-sequence:split-sequence #\, text)) #'<))))))
    (destructuring-bind (&optional day-sched month-sched year-sched)
        (split-sequence:split-sequence #\Space schedule :remove-empty-subseqs t)
      (list (if day-sched (parse day-sched 1 31) (list nil 1 31))
            (if month-sched (parse month-sched 1 12) (list nil 1 12))
            (if year-sched (parse year-sched 1900) (list nil 1900))))))

(defun saver/get-next-time (schedule universal-time &optional (dir t))
  (labels ((leapp (year)
             (or (and (zerop (mod year 4))
                      (not (zerop (mod year 100))))
                 (zerop (mod year 400))))
           (clamp-day-rule (day-rule month year)
             (destructuring-bind (lst &optional (min 0) max (step 1)) day-rule
               (let ((max-day (case month
                                (2 (if (leapp year) 29 28))
                                ((1 3 5 7 8 10 12) 31)
                                (otherwise 30))))
                 (if (consp lst)
                     (list (remove-duplicates (mapcar (lambda (d) (min d max-day)) lst)))
                     (list nil (min min) (when max (min max max-day)) step)))))
           (next (from rule)
             (destructuring-bind (lst &optional (min 0) max (step 1)) rule
               (if (consp lst)
                   (let ((nv (find from lst :test (if dir #'<= #'>=) :from-end (not dir))))
                     (if nv
                         (values nv nil)
                         (values (car (if dir lst (last lst))) t)))
                   (let* ((m (mod (- from min) step))
                          (nv (if (zerop m) from
                                  (funcall (if dir #'+ #'-) from
                                           (if dir (- step m) m)))))
                     (cond
                       ((and max (> nv max))
                        (if dir
                            (values min t)
                            (values max nil)))
                       ((and min (< nv min))
                        (if dir
                            (values min nil)
                            (values max t)))
                       (t (values nv nil)))))))
           (add (v of)
             (funcall (if dir #'+ #'-) v (if of 1 0)))
           (reset-rule (rule)
             (destructuring-bind (lst &optional (min 0) max (step 1)) rule
               (if (consp lst)
                   (car (if dir lst (last lst)))
                   (if dir min
                       (let ((m (mod (- max min) step)))
                         (- max (if (zerop m) 0 m))))))))
    (multiple-value-bind (second minute hour day month year dow dst-p tz) (decode-universal-time universal-time)
      (declare (ignore second minute hour dow dst-p tz))
      (destructuring-bind (&optional (day-rule '(nil 1 31)) (month-rule '(nil 1 12)) (year-rule '(nil 1900)))
          schedule
        (multiple-value-bind (next-day of-day) (next (add day (not dir))
                                                     (clamp-day-rule day-rule month year))
          (multiple-value-bind (next-month of-month) (next (add month of-day) month-rule)
            (multiple-value-bind (next-year of-year) (next (add year of-month) year-rule)
              (unless of-year
                (let ((next-month (if (= next-year year) next-month (reset-rule month-rule))))
                  (encode-universal-time
                   0 0 0
                   (if (and (= next-month month) (= next-year year)) next-day
                       (reset-rule (clamp-day-rule day-rule next-month next-year)))
                   next-month
                   next-year))))))))))

(defun saver/count-events (from to schedule)
  (loop for ut = (saver/get-next-time schedule from) then (saver/get-next-time
                                                           schedule (+ ut 86400))
     while (< ut to)
     counting ut))

(defun saver/get-payment-info (payment salary &optional (moment (get-universal-time)))
  (let* ((salary (saver/parse-schedule salary))
         (schedule (saver/parse-schedule (saver/payment-schedule payment)))
         (next-payment (saver/get-next-time schedule moment))
         (prev-payment (max (saver/get-next-time schedule moment nil)
                            (or (saver/payment-started payment) 0))))
    (when next-payment
      (let* ((total-periods (saver/count-events prev-payment next-payment salary))
             (saved-periods (saver/count-events prev-payment moment salary))
             (period-amount (floor (saver/payment-amount payment) (max 1 total-periods)))
             (saved-amount (* saved-periods period-amount)))
        (list :next-payment next-payment
              :prev-payment prev-payment
              :total-periods total-periods
              :period-amount period-amount
              :saved-periods saved-periods
              :saved-amount saved-amount
              :left-periods (- total-periods saved-periods)
              :left-amount (- (saver/payment-amount payment) saved-amount))))))

(defun saver/get-period-info (salary payments &optional (moment (get-universal-time)))
  (let ((next-salary (saver/get-next-time (saver/parse-schedule salary) moment)))
    (when next-salary
      (loop for payment in payments
         for cur-info = (saver/get-payment-info payment salary moment)
         for next-info = (saver/get-payment-info payment salary next-salary)
         summing (getf cur-info :saved-amount) into total-saved
         summing (getf cur-info :left-amount) into total-left
         summing (if (> (getf next-info :left-periods) 1)
                     (getf next-info :period-amount)
                     (getf next-info :left-amount)) into total-period
         finally (return
                   (list :next-salary next-salary
                         :total-saved total-saved
                         :total-left total-left
                         :total-period total-period))))))

(defun %saver/format-time (universal-time)
  (when universal-time
    (multiple-value-bind (sec min hour day month year dow dst-p tz)
        (decode-universal-time universal-time)
      (declare (ignore sec min hour dow dst-p tz))
      (format nil "~4,'0D-~2,'0D-~2,'0D" year month day))))

;; Database
(def-db-init
    (db-execute "create table if not exists saver_payments (chat_id, name, amount, schedule, started, notified)")
    (db-execute "create unique index if not exists saver_payments_chat_id_name_idx on saver_payments (chat_id, name)")
    (db-execute "create table if not exists saver_salaries (chat_id, schedule, notified)")
    (db-execute "create unique index if not exists saver_salaries_chat_id_idx on saver_salaries (chat_id)"))

(defun %db/saver/make-payment (row)
  (when row
    (make-saver/payment :name (nth 0 row)
                        :amount (nth 1 row)
                        :schedule (nth 2 row)
                        :started (nth 3 row))))

(defun db/saver/get-payments (chat-id)
  (mapcar #'%db/saver/make-payment
          (db-select "select name, amount, schedule, started from saver_payments where chat_id = ? order by started" chat-id)))

(defun db/saver/get-not-notified-payments (notified)
  (loop for row in (db-select "select name, amount, schedule, started, chat_id from saver_payments where notified is null or notified != ?" (%saver/format-time notified))
     collect (cons (nth 4 row) (%db/saver/make-payment row))))

(defun db/saver/set-payment-notified (chat-id name moment)
  (db-execute "update saver_payments set notified = ? where chat_id = ? and name = ?"
              (%saver/format-time moment) chat-id name))

(defun db/saver/add-payment (chat-id payment)
  (with-slots (name amount schedule started) payment
    (db-execute "insert into saver_payments (chat_id, name, amount, schedule, started) values (?, ?, ?, ?, ?)"
                chat-id name amount schedule started)))

(defun db/saver/del-payment (chat-id name)
  (db-execute "delete from saver_payments where chat_id = ? and name = ?" chat-id name))

(defun db/saver/get-salary (chat-id)
  (caar (db-select "select schedule from saver_salaries where chat_id = ?" chat-id)))

(defun db/saver/get-not-notified-salaries (notified)
  (loop for row in (db-select "select chat_id, schedule from saver_salaries where notified is null or notified != ?" (%saver/format-time notified))
     collect (cons (nth 0 row) (nth 1 row))))

(defun db/saver/set-salary-notified (chat-id moment)
  (db-execute "update saver_salaries set notified = ? where chat_id = ?"
              (%saver/format-time moment) chat-id))

(defun db/saver/set-salary (chat-id schedule)
  (db-transaction
    (db-execute "delete from saver_salaries where chat_id = ?" chat-id)
    (db-execute "insert into saver_salaries (chat_id, schedule) values (?, ?)" chat-id schedule)))

;; Cron
(defun saver/find-today-payments (&optional (moment (get-universal-time)))
  (remove-if-not (lambda (p) (string= (%saver/format-time moment)
                                      (%saver/format-time
                                       (saver/get-next-time
                                        (saver/parse-schedule (saver/payment-schedule p))
                                        moment))))
                 (db/saver/get-not-notified-payments moment)
                 :key #'cdr))

(defun %saver/format-payment-notification (payment moment)
  (format nil "'~A' надо оплатить *~A* на сумму _~$_"
          (saver/payment-name payment)
          (%saver/format-time moment)
          (/ (saver/payment-amount payment) 100)))

(defun saver/find-today-salaries (&optional (moment (get-universal-time)))
  (remove-if-not (lambda (p) (string= (%saver/format-time moment)
                                      (%saver/format-time (saver/get-next-time
                                                           (saver/parse-schedule p) moment))))
                 (db/saver/get-not-notified-salaries moment)
                 :key #'cdr))

(defun %saver/format-salary-notification (salary payments moment)
  (let ((period-info (saver/get-period-info salary payments moment)))
    (format nil "*~A* зарплата. Отложи _~$_!"
            (%saver/format-time (getf period-info :next-salary))
            (/ (getf period-info :total-period) 100))))

(defcron process-saver (:hour '*)
  (let* ((moment (get-universal-time))
         (hour (nth 2 (multiple-value-list (decode-universal-time moment)))))
    (when (>= hour *saver-notify-hour*)
      (dolist (cp (saver/find-today-payments moment))
        (db-transaction
          (send-response (car cp) (%saver/format-payment-notification (cdr cp) moment))
          (db/saver/set-payment-notified (car cp) (saver/payment-name (cdr cp)) moment)))
      (dolist (cs (saver/find-today-salaries moment))
        (db-transaction
          (send-response (car cs)
                         (%saver/format-salary-notification (cdr cs)
                                                            (db/saver/get-payments (car cs))
                                                            moment))
          (db/saver/set-salary-notified (car cs) moment))))))


;; Bot subcommands
(defun %saver/format-info (payments salary &optional (moment (get-universal-time)))
  (let* (closest-time
         closest-payment
         (payments-info
          (loop for payment in payments
             for idx from 1
             for info = (saver/get-payment-info payment salary moment)
             when info
             when (or (null closest-time)
                      (< (getf info :next-payment) closest-time))
             do (setf closest-time (getf info :next-payment)
                      closest-payment payment)
             collect (format nil "~D) ~A по [~A]: накоплено _~$_ из _~$_, осталось _~$_ за ~A платежа"
                             idx
                             (saver/payment-name payment)
                             (saver/payment-schedule payment)
                             (/ (getf info :saved-amount) 100)
                             (/ (saver/payment-amount payment) 100)
                             (/ (getf info :left-amount) 100)
                             (getf info :left-periods))))
        (period-info (saver/get-period-info salary payments moment)))
    (if payments-info
        (format nil "*Платежи*~%~{~A~^~%~}~%~%Накоплено должно быть _~$_~%Следующее накопление *~A* на _~$_~%Следующий платёж '~A' *~A*, _~$_"
                payments-info
                (/ (getf period-info :total-saved) 100)
                (%saver/format-time (getf period-info :next-salary))
                (/ (getf period-info :total-period) 100)
                (saver/payment-name closest-payment)
                (%saver/format-time closest-time)
                (/ (saver/payment-amount closest-payment) 100))
        "Нет активных платежей.")))

(defun saver/send-info (chat-id)
  (let ((payments (db/saver/get-payments chat-id))
        (salary (db/saver/get-salary chat-id)))
    (if salary
        (if payments
            (bot-send-message chat-id (%saver/format-info payments salary) :parse-mode "markdown")
            (bot-send-message chat-id (format nil "Платежей нет, зарплата: ~A" salary)))
        (send-response chat-id "Зарплата не задана, /saver salary <cron>"))))

(defun saver/set-salary (chat-id args)
  (let ((sched (spaced args)))
    (saver/parse-schedule sched)
    (db/saver/set-salary chat-id sched)
    (send-response chat-id (format nil "Зарплата теперь '~A'" sched))))

(defparameter +saver/add-scanner+ (cl-ppcre:create-scanner "^(.+?) (\\d+(?:\\.\\d*)?) ((?:\\d+(?:,\\d+)*(?:-\\d+)?|\\*)(?:\\/\\d+)?(?: (?:\\d+(?:,\\d+)*(?:-\\d+)?|\\*)(?:\\/\\d+)?){0,2})(?: (\\d{4}-\\d{2}-\\d{2}))?$"))

(defun saver/add-payment (chat-id args)
  (multiple-value-bind (matched groups) (cl-ppcre:scan-to-strings +saver/add-scanner+ (spaced args))
    (if matched
        (let ((payment (make-saver/payment :name (elt groups 0)
                                           :amount (round (* 100 (read-from-string (elt groups 1))))
                                           :schedule (elt groups 2)
                                           :started (if (elt groups 3)
                                                        (destructuring-bind (year month day)
                                                            (mapcar #'parse-integer
                                                                    (split-sequence:split-sequence
                                                                     #\- (elt groups 3)))
                                                          (encode-universal-time 0 0 0 day month year))
                                                        (get-universal-time)))))
          (saver/get-next-time (saver/parse-schedule (saver/payment-schedule payment))
                               (get-universal-time))
          (handler-case
              (db/saver/add-payment chat-id payment)
            (error (e) (send-response chat-id (format nil "Платёж '~A' уже есть!"
                                                      (saver/payment-name payment)))))
          (saver/send-info chat-id))
        (send-response chat-id "Неправильно. /saver add <title> <amount> <cron> [started]"))))

(defun saver/del-payment (chat-id args)
  (handler-case
      (let ((payment (elt (db/saver/get-payments chat-id) (1- (parse-integer (car args)))))
            (salary (db/saver/get-salary chat-id)))
        (db/saver/del-payment chat-id (saver/payment-name payment))
        (send-response chat-id
                       (format nil "'~A' удалил.~@[ Забрать _~$_ из накопленого.~]"
                               (saver/payment-name payment)
                               (and salary
                                    (/ (getf (saver/get-payment-info payment salary) :saved-amount)
                                       100)))))
    (error (e) (send-response chat-id (format nil "/saver del <idx> [~A]" e)))))

;; Hooks
(def-message-cmd-handler handler-cmd-save (:save :saver)
  (if (null args)
      (saver/send-info chat-id)
      (case (keyify (car args))
        (:salary (saver/set-salary chat-id (rest args)))
        (:add (saver/add-payment chat-id (rest args)))
        (:del (saver/del-payment chat-id (rest args)))
        (t (send-response chat-id "Чот не понял")))))