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

(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:Renov")
                   ((string= num "40817810103001667025") "Savings:For credit")
                   (: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:Renov")
      ((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->journal (move)
  (let* ((account (agets move :account))
         (account1 (get-account-name account))
         (account2 (get-move-account2 move))
         (currency (get-account-currency account))
         (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))))
    (format nil "~A~@[ (~A)~] ~A~@[ ; ~A~]~%    ~37A  ~A~,2F ~A~%    ~37A  ~A~,2F ~A"
            date nil payee description
            account2 (if expense " " "-") amount currency
            account1 (if expense "-" " ") amount currency)))

(defun move->balance (move)
  (let ((account (agets move :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 (nreverse (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 (nreverse (rc/get-account-movements account begin-ut end-ut))
               collect (cons (cons :account (node->alist account t))
                             (node->alist move)))))

(defun format-changes (movements)
  (format nil "```~%~{~A~^~%~%~}```"
          (append (mapcar #'move->journal movements)
                  (list (move->balance (car (last movements)))))))

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

(defun get-chat-last-movements (chat-id &optional (offset +day+))
  (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)))))
         (now (get-universal-time))
         (pre (- now offset))
         (new (get-last-movements pre now)))
      (when new
        (setf (gethash chat-id *cookie-jars*) *cookie-jar*))
      new))

(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-movements*))
          (new (get-chat-last-movements chat-id (* 7 +day+))))
      (when new
        (log:info "Got ~A raif events" (length new))
        (when old
          (alexandria:when-let (changes (set-difference new old :test #'equal))
            (bot-send-message chat-id (format-changes changes) :parse-mode "markdown")))
        (setf (gethash chat-id *last-movements*) new)))))

(def-message-cmd-handler handler-raif (:raif)
  (let ((last (get-chat-last-movements chat-id (* (if args (parse-integer (car args)) 7) +day+))))
    (bot-send-message chat-id (format-changes last) :parse-mode "markdown")))