Nalunch watcher

chatikbot.asd

@@ -9,6 +9,7 @@
                #:cl-date-time-parser
                #:cl-ppcre
                #:clon
+               #:clss
                #:drakma
                #:flexi-streams
                #:local-time

chatikbot.lisp

@@ -78,6 +78,7 @@
               (:feeds (handle-cmd-feeds chat-id id args))
               (:lastrss (handle-cmd-last-rss chat-id id args))
               (:wall (handle-cmd-wall chat-id id args))
+              (:nalunch (handle-cmd-nalunch chat-id id args))
               (otherwise (handle-admin-cmd chat-id text cmd args))))
           (send-dont-understand chat-id (preprocess-input text))))
     (when location
@@ -563,6 +564,26 @@
                                  period))) ;; Update last-id, next-fetch and period
     (error (e) (log:error "~A" e))))
 
+(defun handle-cmd-nalunch (chat-id message-id args)
+  (log:info "handle-cmd-nalunch" chat-id message-id args)
+  (handler-case
+      (if (member chat-id *admins*)
+          (send-response chat-id (nalunch-format (nalunch-recent)))
+          (send-dont-understand chat-id))
+    (error (e)
+      (log:error "~A" e)
+      (telegram-send-message chat-id (format nil "~A" e)))))
+
+(defvar *nalunch-last-result* nil "Last check result")
+(defun process-nalunch ()
+  (handler-case
+      (let ((result (nalunch-recent)))
+        (unless (equal (aget :balance *nalunch-last-result*)
+                       (aget :balance result))
+          (send-response (car *admins*) (nalunch-format result t))
+          (setf *nalunch-last-result* result)))
+    (error (e) (log:error "~A" e))))
+
 (defun process-watchdog ()
   (ignore-errors
     (close
@@ -633,6 +654,13 @@
       :allow-now-p t)
      :name "YIT" :thread t))
 
+  ;; Nalunch
+  (clon:schedule-function
+   #'process-nalunch (clon:make-scheduler (clon:make-typed-cron-schedule
+                                           :minute '(member 0 15 30 45))
+                                          :allow-now-p t)
+   :name "Nalunch" :thread t)
+
   ;; Start getUpdates thread
   (bordeaux-threads:make-thread
    (lambda () (loop-with-error-backoff #'process-updates))

nalunch.lisp

@@ -0,0 +1,64 @@
+(in-package #:chatikbot)
+
+(defvar *nalunch-username* nil "Username")
+(defvar *nalunch-password* nil "Password")
+(defvar *nalunch-cookie-jar* (make-instance 'drakma:cookie-jar) "Cookie storage")
+
+
+(defparameter +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+ (puri:uri "https://www.nalunch.ru/Mobile/"))
+(defparameter +nalunch-login+ (puri:uri "https://www.nalunch.ru/Mobile/Account/Login"))
+
+(defun nalunch-auth (&optional body)
+  (let* ((body (or body
+                   (drakma:http-request +nalunch-login+ :cookie-jar *nalunch-cookie-jar* :user-agent +mobile-ua+)))
+         (dom (plump:parse body))
+         (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 *nalunch-username*)
+             when (string= name "Password") collect (cons name *nalunch-password*)))
+         (response (drakma:http-request +nalunch-login+
+                                        :method :post
+                                        :parameters parameters
+                                        :cookie-jar *nalunch-cookie-jar*
+                                        :user-agent +mobile-ua+)))
+    (when (search "id=\"LoginForm\"" response)
+      (error "Bad username or password"))
+    response))
+
+(defun nalunch-recent ()
+  (multiple-value-bind (body status headers uri)
+      (drakma:http-request +nalunch-mobile+ :cookie-jar *nalunch-cookie-jar* :user-agent +mobile-ua+)
+    (declare (ignore status headers))
+    (let* ((body (if (puri:uri= uri +nalunch-mobile+)
+                     body
+                     (nalunch-auth body)))
+           (dom (plump:parse body))
+           (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-feed_date" day)
+                                for time = (select-text ".transaction_time" el)
+                                for price = (parse-integer (select-text ".transaction_price" el))
+                                for place = (select-text ".transaction-title" el)
+                                collect (list (cons :time (format nil "~A ~A" date time))
+                                              (cons :price price)
+                                              (cons :place place))))))
+
+      (list (cons :balance balance)
+            (cons :recent recent)))))
+
+(defun nalunch-format (result &optional last)
+  (let* ((balance (aget :balance result))
+         (all (aget :recent result))
+         (recent (cons (car all) (unless last (cdr all)))))
+    (format nil "🍴 Баланс ~A руб.~{~&~A~}"
+            balance
+            (mapcar (lambda (meal) (format nil "~A @ ~A — ~A руб."
+                                           (aget :time meal) (aget :place meal) (aget :price meal)))
+                    recent))))

utils.lisp

@@ -132,12 +132,15 @@ is replaced with replacement."
 (defun get-by-tag (node tag)
   (nreverse (org.shirakumo.plump.dom::get-elements-by-tag-name node tag)))
 
+(defun select-text (selector node)
+  (string-trim '(#\Newline #\Space #\Return) (plump:text (elt (clss:select selector node) 0))))
+
 ;; JSON processing
 (defun json-request (url &key (method :get) parameters (object-as :alist))
   (multiple-value-bind (stream status headers uri http-stream)
       (drakma:http-request (http-default url) :method method :parameters parameters
-                             :external-format-out :utf-8
-                             :force-binary t :want-stream t :decode-content t)
+                           :external-format-out :utf-8
+                           :force-binary t :want-stream t :decode-content t)
     (declare (ignore status headers))
     (unwind-protect
          (progn