chatikbot/plugins/nalunch.lisp

(in-package :cl-user)
(defpackage chatikbot.plugins.nalunch
  (:use :cl :chatikbot.common))
(in-package :chatikbot.plugins.nalunch)

(defvar *nalunch/calend* nil "Working calendar exceptions")

(defparameter +nalunch/mobile-ua+ "Mozilla/5.0 (Linux; Android 4.4.4; Nexus 5 Build/KTU84P) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/38.0.2125.114 Mobile Safari/537.36"
  "Mobile UA")
(defparameter +nalunch/mobile-uri+ "https://www.nalunch.ru/Mobile")
(defparameter +nalunch/login-uri+ "https://www.nalunch.ru/Mobile/Account/Login")
(defparameter +nalunch/basicdata-calend+ "http://basicdata.ru/api/json/calend/")

(defun nalunch/auth (login pass cookies &optional dom)
  (let* ((dom (or dom
                  (xml-request +nalunch/login-uri+ :cookie-jar cookies :user-agent +nalunch/mobile-ua+)))
         (form (plump:get-element-by-id dom "LoginForm"))
         (parameters
          (loop for input in (get-by-tag form "input")
             for name = (plump:get-attribute input "name")
             for value = (plump:get-attribute input "value")
             when (and name value) collect (cons name value)
             when (string= name "UserName") collect (cons name login)
             when (string= name "Password") collect (cons name pass))))
    (multiple-value-bind (response status response-headers)
        (http-request +nalunch/login-uri+
                      :method :post
                      :content parameters
                      :cookie-jar cookies
                      :user-agent +nalunch/mobile-ua+)
      (when (and (member status '(301 302 303 307) :test #'=)
                 (gethash "location" response-headers))
        (setf response (http-request (quri:merge-uris
                                      (quri:uri (gethash "location" response-headers))
                                      (quri:uri +nalunch/login-uri+))
                                     :cookie-jar cookies
                                     :user-agent +nalunch/mobile-ua+)))
      (when (search "id=\"LoginForm\"" response)
        (error "Bad username or password"))
      (if (search "<title>Чек</title>" response) ;; Reload feed page on 'Cheque'
          (xml-request +nalunch/mobile-uri+ :cookie-jar cookies :user-agent +nalunch/mobile-ua+)
          (plump:parse response)))))

(defun nalunch/recent (login pass &optional cookies)
  (let ((cookies (or cookies (cl-cookie:make-cookie-jar))))
    (multiple-value-bind (dom status headers uri)
        (xml-request +nalunch/mobile-uri+ :cookie-jar cookies :user-agent +nalunch/mobile-ua+)
      (declare (ignore status headers))
      (let* ((dom (if (quri:uri= uri (quri:uri +nalunch/mobile-uri+))
                       dom
                       (nalunch/auth login pass cookies dom)))
             (balance (parse-integer (plump:text (elt (clss:select ".newswire-header_balance" dom) 0))))
             (recent (loop for day across (clss:select ".day-feed" dom)
                        append (loop for el across (clss:select ".media" day)
                                  for date = (select-text day ".day-feed_date")
                                  for time = (select-text el ".transaction_time")
                                  for price = (parse-float (select-text el ".transaction_price"))
                                  for place = (select-text el ".transaction-title")
                                  collect (list (cons :date date)
                                                (cons :time time)
                                                (cons :price price)
                                                (cons :place place))))))
        (list (cons :balance balance)
              (cons :recent recent))))))

(defsetting *currency* "RUB")
(defsetting *expense-account* "expenses:Food:Work")
(defsetting *liabilities-account* "liabilities:nalunch")
(defparameter +months+ '("" "января" "февраля" "марта" "апреля" "мая" "июня" "июля" "августа" "сентября" "октября" "ноября" "декабря"))

(defun date-time->ut (date time)
  (let* ((decoded-now (multiple-value-list
                       (decode-universal-time (get-universal-time) *chat-default-timezone*)))
         (year (nth 5 decoded-now))
         (hour (parse-integer time :start 0 :end 2))
         (minute (parse-integer time :start 3 :end 5))
         (day (if (string= date "Сегодня")
                  (nth 3 decoded-now)
                  (parse-integer date :start 0 :end 2)))
         (month (if (string= date "Сегодня")
                  (nth 4 decoded-now)
                  (position (subseq date 3) +months+ :test #'equal))))
    (encode-universal-time 0 minute hour day month year *chat-default-timezone*)))

(defun recent->entry (recent)
  (let* ((pta-ledger (find-package :pta-ledger))
         (make-entry (symbol-function (intern "MAKE-ENTRY" pta-ledger)))
         (make-posting (symbol-function (intern "MAKE-POSTING" pta-ledger)))
         (make-amount (symbol-function (intern "MAKE-AMOUNT" pta-ledger)))
         (date (date-time->ut (agets recent :date) (agets recent :time)))
         (payee (agets recent :place))
         (amount (agets recent :price)))
    (funcall make-entry
     :date date
     :description payee
     :postings (list
                (funcall make-posting
                 :account *expense-account*
                 :amount (funcall make-amount
                          :quantity amount
                          :commodity *currency*))
                (funcall make-posting
                 :account *liabilities-account*
                 :amount (funcall make-amount
                          :quantity (* -1 amount)
                          :commodity *currency*))))))

(defun %nalunch/get-calend (year)
  (setf year (princ-to-string year))
  (unless (aget year *nalunch/calend*)
    (setf *nalunch/calend* (aget "data" (json-request +nalunch/basicdata-calend+))))
  (aget year *nalunch/calend*))

(defun %nalunch/get-working-days (year month)
  (let* ((exceptions (aget (princ-to-string month) (%nalunch/get-calend year)))
         (days-in-month (local-time:days-in-month month year)))
    (loop for day from 1 upto days-in-month
       for ts = (local-time:encode-timestamp 0 0 0 0 day month year)
       for dof = (local-time:timestamp-day-of-week ts)
       for exc = (aget "isWorking" (aget (princ-to-string day) exceptions))
       when (or (and (<= 1 dof 5)
                     (not (equal 2 exc)))
                (and (or (= dof 0) (= dof 6))
                     (or (equal 0 exc)
                         (equal 3 exc))))
       collect day)))

(defun %nalunch/format (result &optional last)
  (let* ((balance (aget :balance result))
         (all (aget :recent result))
         (recent (cons (car all) (unless last (cdr all))))
         (now (local-time:now))
         (left-working-days (length (remove-if #'(lambda (d) (<= d (local-time:timestamp-day now)))
                                               (%nalunch/get-working-days (local-time:timestamp-year now)
                                                                          (local-time:timestamp-month now))))))
    (format nil "🍴 Баланс ~A руб~@[ на ~A дней, по ~$ руб~].~{~&~A~}"
            balance left-working-days (/ balance (max left-working-days 1))
            (mapcar (lambda (meal) (format nil "~A ~A @ ~A — ~A руб."
                                           (aget :date meal) (aget :time meal)
                                           (aget :place meal) (aget :price meal)))
                    recent))))

;; Cron
(defvar *nalunch/last-results* (make-hash-table) "Last check results")
(defvar *nalunch/jars* (make-hash-table) "Cookie jars")
(defcron process-nalunch (:minute '(member 0 10 20 30 40 50))
  (dolist (chat-id (lists-get :nalunch))
    (with-secret (login-pass (list :nalunch chat-id))
      (if login-pass
          (let* ((cookie-jar (or (gethash chat-id *nalunch/jars*)
                                 (cl-cookie:make-cookie-jar)))
                 (ledger-package (find-package :chatikbot.plugins.ledger))
                 (old (gethash chat-id *nalunch/last-results*))
                 (new (nalunch/recent (car login-pass) (cdr login-pass) cookie-jar)))
            (when new
              (when (and old (not (equal (aget :balance old)
                                         (aget :balance new))))
                (bot-send-message chat-id (%nalunch/format new t))
                (when ledger-package
                  (let ((new-chat-entry (symbol-function
                                         (intern "LEDGER/NEW-CHAT-ENTRY" ledger-package))))
                    (dolist (recent (set-difference (agets new :recent) (agets old :recent) :test #'equalp))
                      (funcall new-chat-entry chat-id (recent->entry recent))))))
              (setf (gethash chat-id *nalunch/last-results*) new
                    (gethash chat-id *nalunch/jars*) cookie-jar)))
          (progn
            (log:warn "nalunch no login/pass for" chat-id))))))

;; Hooks
(defun nalunch/handle-set-cron (chat-id enable)
  (lists-set-entry :nalunch chat-id enable)
  (bot-send-message chat-id
                    (if enable
                        "Включил рассылку. '/nalunch off' чтобы выключить, /nalunch - показать последние."
                        "Без рассылки. '/nalunch on' - включить, /nalunch - последние.")))

(defun nalunch/handle-auth (chat-id login pass)
  (let ((cookies (cl-cookie:make-cookie-jar)))
    (handler-case
        (progn
          (nalunch/auth login pass cookies)
          (secret-set `(:nalunch ,chat-id) (cons login pass))
          (nalunch/handle-set-cron chat-id t))
      (error () (bot-send-message chat-id "Чот не смог, пропробуй другие.")))))

(defun nalunch/handle-recent (chat-id)
  (with-secret (login-pass (list :nalunch chat-id))
    (bot-send-message chat-id
                      (if login-pass
                          (let* ((cookies (or (gethash chat-id *nalunch/jars*)
                                              (cl-cookie:make-cookie-jar)))
                                 (data (nalunch/recent (car login-pass) (cdr login-pass) cookies)))
                            (if data
                                (progn
                                  (setf (gethash chat-id *nalunch/jars*) cookies)
                                  (%nalunch/format data))
                                "Не смог получить данные. Попробуй перелогинься. /nalunch <login> <pass>"))
                          "Нужен логин-пароль. /nalunch <login> <pass>")
                      :parse-mode "markdown")))

(def-message-cmd-handler handle-cmd-nalunch (:nalunch)
  (cond
    ((= 1 (length args))
     (nalunch/handle-set-cron chat-id (equal "on" (car args))))
    ((= 2 (length args)) (apply 'nalunch/handle-auth chat-id args))
    (:otherwise (nalunch/handle-recent chat-id))))