chatikbot/plugins/saver.lisp

(in-package #:chatikbot)

(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 t) (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)
     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 :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
      (let ((total-period-amount
             (loop for payment in payments
                for info = (saver/get-payment-info payment salary moment)
                summing (if (> (getf info :left-periods) 1) (getf info :period-amount) (getf info :left-amount)))))
        (list :next-salary next-salary :total-period-amount total-period-amount)))))

;; 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/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/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
;;;; TODO

;; Hooks

;; Bot subcommands
(defun %saver/format-info (payments salary)
  (let ((payments-info
         (loop for payment in payments
            for info = (saver/get-payment-info payment salary)
            collect (format nil "~A on [~A]: saved ~$ of ~$, left ~$ in ~A periods"
                            (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)))
    (multiple-value-bind (sec min hour day month year dow dst-p tz)
        (decode-universal-time (getf period-info :next-salary))
      (declare (ignore sec min hour dow dst-p tz))
      (format nil "~{~A~^~%~}~%~%Next save on ~4,'0D-~2,'0D-~2,'0D with ~$" payments-info
              year month day (/ (getf period-info :total-period-amount) 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
            (send-response chat-id (%saver/format-info payments salary))
            (send-response chat-id (format nil "No payments yet, salary: ~A" salary)))
        (send-response chat-id "No salary set, /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 "Salary is now '~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/parse-schedule (elt groups 2))
          (db/saver/add-payment chat-id payment)
          (saver/send-info chat-id))
        (send-response chat-id "Bad format. /saver add <title> <amount> <cron> [started]"))))

(defun saver/del-payment (chat-id args))

(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 "Unknown command")))))