|
|
@@ -0,0 +1,218 @@
|
|
|
+(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")))))
|
