[nalunch] Use api via poller.

common.lisp

@@ -184,5 +184,5 @@
            :poller-cant-authenticate
 
            :poller-call
-           :poller-poll-list))
+           :poller-poll-lists))
 (in-package :chatikbot.common)

plugins/nalunch.lisp

@@ -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*))))))

poller.lisp

@@ -1,9 +1,8 @@
 (in-package :cl-user)
 (defpackage chatikbot.poller
-  (:use :cl :chatikbot.utils)
+  (:use :cl :chatikbot.utils :chatikbot.secrets)
   (:export :*poller-token*
            :*poller-module*
-           :filled
            :rest-parameters
 
            :poller-request
@@ -15,7 +14,8 @@
            :poller-cant-authenticate
 
            :poller-call
-           :poller-poll-list))
+           :poller-poll-lists))
+(in-package :chatikbot.poller)
 
 (defvar *tokens* (make-hash-table) "Module's tokens store")
 (defvar *state* (make-hash-table) "Module's state store")

utils.lisp

@@ -73,7 +73,8 @@
            :get-chat-timezone
            :same-time-in-chat
            :group-by
-           :pmapcar))
+           :pmapcar
+           :filled))
 (in-package #:chatikbot.utils)
 
 ;; Special variables