chatikbot/plugins/raiffeisen.lisp

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '(:cxml-stp :pta-ledger)))

(defvar *raif-ws* "https://connect.raiffeisen.ru/Mobile-WS/services/" "Base WS URL")
(defvar *ua* "Dalvik/2.1.0 (Linux; U; Android 6.0.1; ONE A2003 Build/MMB29M) Android/3.19.0(459)" "User agent")
(defvar *soap-dom* (cxml:parse "<?xml version='1.0' encoding='UTF-8' standalone='yes' ?><soapenv:Envelope xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xmlns:xsd=\"http://entry.rconnect/xsd\" xmlns:ser=\"http://service.rconnect\" xmlns:soapenv=\"http://schemas.xmlsoap.org/soap/envelope/\" xmlns:soapenc=\"http://schemas.xmlsoap.org/soap/encoding/\"><soapenv:Header /><soapenv:Body></soapenv:Body></soapenv:Envelope>" (stp:make-builder)) "XML SOAP raif service envelope")
(defparameter +ns-soap-env+ "http://schemas.xmlsoap.org/soap/envelope/" "Soap envelope xmlns")
(defparameter +ns-rconnect+ "http://service.rconnect" "Service r-connect xmlns")
(defparameter +ct-xml+ "text/xml;charset=UTF-8" "XML Content-Type")
(defvar *rc-auth-service* "RCAuthorizationService")
(defvar *rc-account-service* "RCAccountService")
(defvar *cookie-jar* nil "Active cookie jar")
(defvar *credentials-provider* nil "Active credentials provider")

(defun get-service-url (service-name)
  (concatenate 'string *raif-ws* service-name))

(defun soap-request-serialize (body)
  (let* ((doc (stp:copy *soap-dom*))
         (n-body (stp:find-recursively-if (stp:of-name "Body" +ns-soap-env+) doc)))
    (stp:append-child n-body (stp:copy body))
    (stp:serialize doc (cxml:make-string-sink))))

(define-condition soap-error (error)
  ((name :initarg :name :reader soap-error-name)
   (message :initarg :message :reader soap-error-message))
  (:report (lambda (condition stream)
             (with-slots (name message) condition
               (format stream "Soap error ~A: ~A" name message)))))

(defun %rs/login (login password)
  (let ((n-method (stp:make-element "ser:login" +ns-rconnect+))
        (n-login (stp:make-element "login"))
        (n-password (stp:make-element "password")))
    (stp:append-child n-login (stp:make-text login))
    (stp:append-child n-password (stp:make-text password))
    (stp:append-child n-method n-login)
    (stp:append-child n-method n-password)
    n-method))

(defun %r-call (service request)
  (let* ((body
          (handler-case
              (http-request (get-service-url service)
                            :method :post
                            :content (soap-request-serialize request)
                            :cookie-jar *cookie-jar*
                            :user-agent *ua*
                            :headers `(("SOAPAction" . "")
                                       (:content-type . ,+ct-xml+)))
            (dex:http-request-internal-server-error (e)
              (dex:response-body e))))
         (x/body
          (stp:first-child
           (stp:find-recursively-if
            (stp:of-name "Body" +ns-soap-env+)
            (cxml:parse body (stp:make-builder))))))
    (if (string-equal (stp:local-name x/body) "Fault")
        (let ((name (stp:local-name (stp:first-child (stp:find-recursively-if (stp:of-name "detail") x/body))))
              (message (stp:data (stp:first-child (stp:find-recursively-if (stp:of-name "faultstring") x/body)))))
          (if (and *credentials-provider*
                   (string-equal name "sessionExpiredFault"))
              (progn
                (funcall *credentials-provider*
                         (lambda (login password)
                           (%r-call *rc-auth-service* (%rs/login login password))))
                (%r-call service request))
              (error 'soap-error :name name :message message)))
        x/body)))

(defun rc/get-batch-response ()
  (%r-call *rc-auth-service* (stp:make-element "ser:getBatchResponse" +ns-rconnect+)))

(defun get-accounts (batch-response)
  (stp:filter-recursively (stp:of-name "accounts") batch-response))

(defun %rs/get-last-account-movements (account count)
  (let ((n-method (stp:make-element "ser:GetLastAccountMovements" +ns-rconnect+))
        (n-account (stp:copy account))
        (n-count (stp:make-element "count")))
    (setf (stp:local-name n-account) "account")
    (stp:append-child n-count (stp:make-text (princ-to-string count)))
    (stp:append-child n-method n-account)
    (stp:append-child n-method n-count)
    n-method))

(defun rc/get-last-account-movements (account count)
  (let ((info (%r-call *rc-account-service* (%rs/get-last-account-movements account count))))
    (stp:filter-recursively (stp:of-name "return") info)))

(defun %rs/get-account-movements (account start-date end-date)
  (let ((n-method (stp:make-element "ser:GetAccountMovements" +ns-rconnect+))
        (n-account (stp:copy account))
        (n-start-date (stp:make-element "startDate"))
        (n-end-date (stp:make-element "endDate")))
    (setf (stp:local-name n-account) "account")
    (stp:append-child n-start-date (stp:make-text start-date))
    (stp:append-child n-end-date (stp:make-text end-date))
    (stp:append-child n-method n-account)
    (stp:append-child n-method n-start-date)
    (stp:append-child n-method n-end-date)
    n-method))

(defun rc/get-account-movements (account start-ut end-ut)
  (labels ((format-ut (ut)
             (multiple-value-bind (sec min hour day month year)
                 (decode-universal-time ut)
               (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D.0"
                       year month day hour min sec))))
    (let ((info (%r-call *rc-account-service*
                         (%rs/get-account-movements account
                                                    (format-ut start-ut)
                                                    (format-ut end-ut)))))
      (stp:filter-recursively (stp:of-name "return") info))))

(defun tag->keyword (tag)
  (setf tag (cl-ppcre:regex-replace-all "([a-z])([A-Z])" tag '(0 "-" 1)))
  (setf tag (cl-ppcre:regex-replace-all "_" tag "-"))
  (intern (string-upcase tag) :keyword))

(defun node->alist (node &optional keep-id)
  (let (res)
    (stp:do-children (child node (nreverse res))
      (let ((name (stp:local-name child)))
        (when (or keep-id
                  (not (string-equal "id" name)))
          (push (cons (tag->keyword name)
                      (stp:string-value child))
                res))))))

(defun get-account-currency (account)
  (let ((currency (agets account :currency)))
    (cond
      ((equal currency "RUR") "RUB")
      (t currency))))

(defun get-account-name (account)
  (let ((num (agets account :number)))
    (concatenate 'string "assets:Raiffeisen:"
                 (cond
                   ((string= num "40817810503000266700") "Debit")
                   ((string= num "40817978803000110883") "Savings:EUR")
                   ((string= num "40817810203001534278") "Savings:Kopilka")
                   ((string= num "40817810103001667025") "Saver")
                   (:overwise (concatenate 'string
                                           (agets account :account-type)
                                           ":"
                                           num
                                           ":"
                                           (get-account-currency account)))))))

(defun get-move-payee (move)
  (agets move :short-description))

(defun get-move-description (move)
  (let ((full (agets move :full-description)))
    (unless (or (zerop (length full))
                (string= "CARD **" (subseq full 0 (min (length full) 7))))
      (cl-ppcre:regex-replace-all "\\s" full " "))))

(defun get-move-account2 (move)
  (let ((desc (agets move :short-description)))
    (cond
      ((equal desc "P/O 001,40817810503000266700RC") "assets:Raiffeisen:Debit")
      ((equal desc "P/O 001,40817810203001534278RC") "assets:Raiffeisen:Savings:Kopilka")
      ((equal desc "TINKOFF BANK CARD2CARD MOSCOW") "assets:Tinkoff:Debit")
      ((equal (subseq desc 0 (min 7 (length desc))) "RBA ATM") "assets:Cash:RUB")
      (t (if (string= "1" (agets move :type)) "income" "expenses")))))

(defun short-date (date)
  (cl-ppcre:regex-replace-all "-" (subseq date 0 10) "/"))

(defun move->entry (move)
  (let* ((account (agets move :account))
         (account1 (get-account-name account))
         (account2 (get-move-account2 move))
         (currency (get-account-currency account))
         (date (pta-ledger:parse-date (short-date (agets move :commit-date))))
         (payee (get-move-payee move))
         (description (get-move-description move))
         (amount (parse-float (agets move :amount)))
         (expense (equal "0" (agets move :type))))
    (pta-ledger:make-entry
     :date date
     :description payee
     :comment description
     :postings (list
                (pta-ledger:make-posting
                 :account account2
                 :amount (pta-ledger:make-amount
                          :quantity (* amount (if expense 1 -1))
                          :commodity currency))
                (pta-ledger:make-posting
                 :account account1
                 :amount (pta-ledger:make-amount
                          :quantity (* amount (if expense -1 1))
                          :commodity currency))))))

(defun account->balance (account)
  (format nil "; balance ~A ~A  = ~,2F ~A"
          (short-date (agets account :balance-date))
          (get-account-name account)
          (parse-float (agets account :balance))
          (get-account-currency account)))


(defun get-last-n-movements (&optional (count 10))
  (loop for account in (get-accounts (rc/get-batch-response))
     append (loop for move in (rc/get-last-account-movements account count)
               collect (cons (cons :account (node->alist account t))
                             (node->alist move)))))

(defun get-last-movements (begin-ut end-ut)
  (loop for account in (get-accounts (rc/get-batch-response))
     append (loop for move in (rc/get-account-movements account begin-ut end-ut)
               collect (cons (cons :account (node->alist account t))
                             (node->alist move)))))

(defun format-entries (changes)
  (loop for entry in changes
     for text = (pta-ledger:render entry)
     with page
     when (> (+ (length page) (length text) 2)
             2048)
     collect (format nil "```~%~A```" page) and do (setf page nil)
     do (setf page (format nil "~@[~A~%~%~]~A" page text))))

(defun format-balance (accounts)
  (format nil "```~%~{~A~^~%~}```" (mapcar #'account->balance accounts)))

;; Cron
(defvar *last-entries* (make-hash-table) "Last per-chat entries")
(defvar *cookie-jars* (make-hash-table) "Per-chat cookie jars")

(defmacro with-chat-credentials ((chat-id) &body body)
  `(let* ((*cookie-jar* (or (gethash ,chat-id *cookie-jars*)
                            (cl-cookie:make-cookie-jar)))
          (*credentials-provider* (lambda (authenticator)
                                   (with-secret (login-pass (list :raiffeisen ,chat-id))
                                     (if login-pass
                                         (apply authenticator login-pass)
                                         (error "no raiffeisen credentials for ~A" ,chat-id))))))
     (prog1 (progn ,@body)
       (setf (gethash chat-id *cookie-jars*) *cookie-jar*))))

(defun get-chat-last-entries (chat-id &optional (offset +day+))
  (with-chat-credentials (chat-id)
    (let* ((now (get-universal-time))
           (pre (- now offset)))
      (sort (mapcar #'move->entry (get-last-movements pre now))
            #'< :key #'pta-ledger:entry-date))))

(defun get-chat-accounts (chat-id)
  (with-chat-credentials (chat-id)
    (mapcar #'node->alist (get-accounts (rc/get-batch-response)))))

(defcron process-raiffeisen (:minute '(member 0 5 10 15 20 25 30 35 40 45 50 55))
  (dolist (chat-id (lists-get :raiffeisen))
    (let ((old (gethash chat-id *last-entries*))
          (new (get-chat-last-entries chat-id (* 7 +day+)))
          (ledger-package (find-package :chatikbot.plugins.ledger)))
      (when new
        (when old
          (alexandria:when-let (changes (set-difference new old :test #'equalp))
            (log:info changes)
            (if ledger-package
                (let ((new-chat-entry (symbol-function
                                       (intern "LEDGER/NEW-CHAT-ENTRY" ledger-package))))
                  (dolist (entry changes)
                    (funcall new-chat-entry chat-id entry)))
                (bot-send-message chat-id (format-entries changes) :parse-mode "markdown"))))
        (setf (gethash chat-id *last-entries*) new)))))

(def-message-cmd-handler handler-raif (:raif)
  (let ((arg (car args)))
    (if (string= arg "bal")
        (bot-send-message chat-id (format-balance (get-chat-accounts chat-id)) :parse-mode "markdown")
        (let ((last (get-chat-last-entries chat-id (* (if arg (parse-integer arg) 7) +day+))))
          (bot-send-message chat-id (format-entries last) :parse-mode "markdown")))))