|
|
@@ -3,93 +3,88 @@
|
|
|
(: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))))))
|
|
|
+(defparameter +api-uri+ "https://www.nalunch.ru/api/" "Nalunch API base url")
|
|
|
+(defvar *calend* nil "Working calendar exceptions")
|
|
|
+(defparameter +basicdata-calend-url+ "http://basicdata.ru/api/json/calend/")
|
|
|
+
|
|
|
+;; poller methods
|
|
|
+(defmethod poller-request ((module (eql :nalunch)) method &rest params)
|
|
|
+ (handler-case
|
|
|
+ (json-request (concatenate 'string +api-uri+ method)
|
|
|
+ :parameters (rest-parameters params)
|
|
|
+ :headers (filled `(("X-AUTH-SIGN" . ,*poller-token*))))
|
|
|
+ (dex:http-request-failed (e) e)))
|
|
|
+(defmethod poller-validate ((module (eql :nalunch)) response)
|
|
|
+ (not (typep response 'dex:http-request-failed)))
|
|
|
+(defmethod poller-authenticate ((module (eql :nalunch)) secret)
|
|
|
+ (destructuring-bind (username . password) secret
|
|
|
+ (agets (poller-request :nalunch "auth" :username username :password password)
|
|
|
+ "token")))
|
|
|
+
|
|
|
+;; API
|
|
|
+(defun user-profile ()
|
|
|
+ (poller-call :nalunch "user/profile"))
|
|
|
+
|
|
|
+(defun user-balance ()
|
|
|
+ (poller-call :nalunch "user/balance"))
|
|
|
+
|
|
|
+(defun get-transactions (&optional month)
|
|
|
+ (let ((month (or month (format-ts (local-time:now)))))
|
|
|
+ (poller-call :nalunch "transactions/GetCHTransactions" :from month)))
|
|
|
+
|
|
|
+(defun get-catering-points (lat lon &key page size)
|
|
|
+ (poller-call :nalunch "cateringpoint/getpointlist" :latitude lat :longitude lon :page page "pageSize" size))
|
|
|
|
|
|
(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)
|
|
|
+
|
|
|
+;; Bot
|
|
|
+(defun get-calend (year)
|
|
|
+ (setf year (princ-to-string year))
|
|
|
+ (unless (aget year *calend*)
|
|
|
+ (setf *calend* (aget "data" (json-request +basicdata-calend-url+))))
|
|
|
+ (aget year *calend*))
|
|
|
+
|
|
|
+(defun get-working-days (year month)
|
|
|
+ (let* ((exceptions (aget (princ-to-string month) (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 format-balance-left (balance)
|
|
|
+ (let* ((balance (aget "sum" balance))
|
|
|
+ (now (local-time:now))
|
|
|
+ (left-working-days (length (remove-if #'(lambda (d) (<= d (local-time:timestamp-day now)))
|
|
|
+ (get-working-days (local-time:timestamp-year now)
|
|
|
+ (local-time:timestamp-month now))))))
|
|
|
+ (format nil "🍴 Баланс ~A руб~@[ на ~A дней, по ~$ руб~]."
|
|
|
+ balance left-working-days (/ balance (max left-working-days 1)))))
|
|
|
+
|
|
|
+(defun format-entries (changes)
|
|
|
+ (text-chunks (mapcar #'pta-ledger:render changes)))
|
|
|
+
|
|
|
+(defun flat-transactions (transactions)
|
|
|
+ (loop for day in transactions
|
|
|
+ appending (agets day "transactionList")))
|
|
|
+
|
|
|
+(defun transaction->entry (tr)
|
|
|
(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)))
|
|
|
+ (date (local-time:timestamp-to-universal
|
|
|
+ (local-time:parse-timestring (agets tr "time"))))
|
|
|
+ (payee (agets tr "catPointName"))
|
|
|
+ (amount (agets tr "sum")))
|
|
|
(funcall make-entry
|
|
|
:date date
|
|
|
:description payee
|
|
|
@@ -105,102 +100,57 @@
|
|
|
: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 transactions->entries (transactions)
|
|
|
+ (mapcar #'transaction->entry (flat-transactions transactions)))
|
|
|
|
|
|
-(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))))
|
|
|
+(defun process-new (diff)
|
|
|
+ (let ((ledger-package (find-package :chatikbot.plugins.ledger)))
|
|
|
+ (if ledger-package
|
|
|
+ (let ((new-chat-entry (symbol-function
|
|
|
+ (intern "LEDGER/NEW-CHAT-ENTRY" ledger-package))))
|
|
|
+ (dolist (tr diff)
|
|
|
+ (funcall new-chat-entry *chat-id* tr)))
|
|
|
+ (bot-send-message (format-entries diff)))))
|
|
|
|
|
|
;; 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))))))
|
|
|
+ (poller-poll-lists :nalunch
|
|
|
+ #'(lambda () (transactions->entries (get-transactions)))
|
|
|
+ #'(lambda (diff)
|
|
|
+ (bot-send-message (format-balance-left (user-balance)))
|
|
|
+ (process-new diff))
|
|
|
+ :key #'(lambda (tr)
|
|
|
+ (local-time:timestamp-to-universal
|
|
|
+ (local-time:parse-timestring (agets tr "time"))))))
|
|
|
|
|
|
;; Hooks
|
|
|
-(defun nalunch/handle-set-cron (chat-id enable)
|
|
|
- (lists-set-entry :nalunch chat-id enable)
|
|
|
- (bot-send-message chat-id
|
|
|
- (if enable
|
|
|
+(defun handle-set-cron (enable)
|
|
|
+ (lists-set-entry :nalunch *chat-id* enable)
|
|
|
+ (bot-send-message (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")))
|
|
|
+(defun handle-auth (login pass)
|
|
|
+ (let ((secret (cons login pass)))
|
|
|
+ (unless (poller-authenticate :nalunch secret)
|
|
|
+ (bot-send-message "Чот не смог, пропробуй другие."))
|
|
|
+ (secret-set `(:nalunch ,*chat-id*) secret)
|
|
|
+ (handle-set-cron t)))
|
|
|
+
|
|
|
+(defun handle-recent (&optional month)
|
|
|
+ (bot-send-message
|
|
|
+ (handler-case
|
|
|
+ (let ((transactions (get-transactions month)))
|
|
|
+ (format-entries (transactions->entries transactions)))
|
|
|
+ (poller-no-secret () "Нужен логин-пароль. /nalunch <login> <pass>")
|
|
|
+ (poller-cant-authenticate () "Не смог получить данные. Попробуй перелогинься. /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))))
|
|
|
+ (let ((a0 (car *args*)))
|
|
|
+ (cond
|
|
|
+ ((= 2 (length *args*)) (apply 'handle-auth *args*))
|
|
|
+ ((and (= 1 (length *args*)) (or (equal "on" a0) (equal "off" a0)))
|
|
|
+ (handle-set-cron (equal "on" a0)))
|
|
|
+ ((equal a0 "bal") (bot-send-message (format-balance-left (user-balance))))
|
|
|
+ (:otherwise (handle-recent (spaced *args*))))))
|
