[raiffeisen] New rest api, refactor alexandria's funcs

chatikbot.lisp

@@ -1,6 +1,6 @@
 (in-package :cl-user)
 (defpackage chatikbot
-  (:use :cl)
+  (:use :cl :alexandria)
   (:import-from :chatikbot.db
                 :with-db
                 :db-init
@@ -11,7 +11,6 @@
                 :*bot-name*
                 :*admins*
                 :aget
-                :flatten
                 :format-ts
                 :run-hooks
                 :loop-with-error-backoff)

common.lisp

@@ -35,9 +35,7 @@
            :replace-all
            :aget
            :agets
-           :mappend
-           :random-elt
-           :flatten
+           :agetter
            :preprocess-input
            :spaced
            :text-chunks

eliza.lisp

@@ -2,7 +2,8 @@
 (defpackage chatikbot.eliza
   (:use :cl
         :chatikbot.patmatch
-        :chatikbot.utils)
+        :chatikbot.utils
+        :alexandria)
   (:export :?is
            :?or
            :?and

plugins/foursquare.lisp

@@ -1,6 +1,6 @@
 (in-package :cl-user)
 (defpackage chatikbot.plugins.foursquare
-  (:use :cl :chatikbot.common))
+  (:use :cl :chatikbot.common :alexandria))
 (in-package :chatikbot.plugins.foursquare)
 
 (defparameter *fsq-checkins-url* "https://api.foursquare.com/v2/checkins/recent"

plugins/raiffeisen.lisp

@@ -1,186 +1,133 @@
 (in-package :cl-user)
 (defpackage chatikbot.plugins.raiffeisen
-  (:use :cl :chatikbot.common))
+  (:use :cl :chatikbot.common :alexandria))
 (in-package :chatikbot.plugins.raiffeisen)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ql:quickload '(:cxml-stp :pta-ledger)))
-
 (defsetting *account-aliases* nil "account to ledger account")
 (defsetting *account-default-prefix* "assets:Raiffeisen")
-(defsetting *move-aliases* nil "move account aliases")
+(defsetting *account-loan-prefix* "liabilities:Raiffeisen")
+(defsetting *move-categories* nil "move categoryId->account")
 (defsetting *account-cash* "assets:Cash:RUB")
 
-(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")
+(defparameter +raif-oauth-url+ "https://online.raiffeisen.ru/oauth/token")
+(defparameter +raif-oauth-basic-auth+ '("oauthUser" . "oauthPassword!@"))
+(defvar *access-token* nil "Currently active access token")
 (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-access-token (username password)
+  (let ((response
+         (json-request +raif-oauth-url+ :method :post
+                       :content `(("grant_type" . "password")
+                                  ("username" . ,username)
+                                  ("password" . ,password))
+                       :basic-auth +raif-oauth-basic-auth+)))
+    (values (agets response "access_token")
+            (agets response "expires_in")
+            (agets response "resource_owner"))))
+
+(defun filled (alist)
+  (remove nil alist :key #'cdr))
+
+(defparameter +raif-rest-url+ "https://online.raiffeisen.ru/rest/")
+(defun %rest (method &optional parameters)
+  (handler-case
+      (json-request (concatenate 'string +raif-rest-url+ method)
+                    :parameters (filled parameters)
+                    :headers (when *access-token*
+                               `((:authorization . ,(concatenate 'string "Bearer " *access-token*)))))
+    (dex:http-request-unauthorized (e)
+      (if *credentials-provider*
+          (progn
+            (funcall *credentials-provider*
+                     (lambda (login password)
+                       (setf *access-token* (get-access-token login password))))
+            (let (*credentials-provider*) ;; Retry call resetting *credentials-provider* to prevent loop
+              (%rest method parameters)))
+          (error e)))))
+
+
+(defun ^request (&key (page 0) (size 20) (sort "date") (order "desc") alien)
+  (%rest "request" `(("page" . ,page)
+                     ("size" . ,size)
+                     ("sort" . ,sort)
+                     ("order" . ,order)
+                     ("alien" . ,(when alien "true")))))
+
+(defun ^transaction (&key (page 0) (size 20) (sort "date") (order "desc"))
+  (%rest "transaction" `(("page" . ,page)
+                         ("size" . ,size)
+                         ("sort" . ,sort)
+                         ("order" . ,order))))
+
+(defun ^account (&key alien)
+  (%rest "account" `(("alien" . ,(when alien "true")))))
+
+(defun ^loan (&key alien)
+  (%rest "loan" `(("alien" . ,(when alien "true")))))
 
 (defun get-account-currency (account)
-  (let ((currency (agets account :currency)))
-    (cond
-      ((equal currency "RUR") "RUB")
-      (t currency))))
+  (agets account "currency" "shortName"))
 
 (defun get-account-name (account)
-  (or (agets *account-aliases* (agets account :number))
-      (format nil "~A:~A:~A:~A"
-              *account-default-prefix*
-              (agets account :account-type)
-              (agets account :number)
-              (get-account-currency account))))
-
+  (if (agets account "leftDebt")
+      (or (agets *account-aliases* (agets account "id"))
+          (format nil "~A:~A:~A:~A"
+                  *account-loan-prefix*
+                  (agets account "type" "id")
+                  (agets account "id")
+                  (get-account-currency account)))
+      (or (agets *account-aliases* (agets account "cba"))
+          (when-let (name (agets account "name"))
+            (format nil "~A:~A" *account-default-prefix* name))
+          (format nil "~A:~A:~A:~A"
+                  *account-default-prefix*
+                  (agets account "type" "name")
+                  (agets account "cba")
+                  (get-account-currency account)))))
+
+(defun get-transaction-account (transaction accounts)
+  (let ((relation (agets transaction "relation"))
+        (related-id (agets transaction "relatedId")))
+    (cond
+      ((equal relation "ACCOUNT")
+       (find related-id accounts :test 'equal :key (agetter "id")))
+      ((equal relation "CARD")
+       (some (lambda (acc)
+               (when (find related-id (agets acc "cards") :test 'equal :key (agetter "id"))
+                 acc))
+             accounts)))))
+
+(defvar *default-payee* "Raiffeisen")
 (defun get-move-payee (move)
-  (agets move :short-description))
+  (or (agets move "merchant")
+      *default-payee*))
 
 (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 " "))))
+  (agets move "note"))
 
 (defun get-move-account2 (move)
-  (let ((desc (agets move :short-description)))
+  (let ((category (agets move "categoryId"))
+        (category-id (agets move "parentCategoryId")))
     (cond
-      ((agets *move-aliases* desc))
-      ((equal (subseq desc 0 (min 7 (length desc))) "RBA ATM") *account-cash*)
-      (t (if (string= "1" (agets move :type)) "income" "expenses")))))
+      ((agets *move-categories* category-id))
+      ((equal category "ATM") *account-cash*)
+      (t (format nil "~A~@[:~A~]"
+                 (if (> (agets move "amount") 0) "income" "expenses") category)))))
 
 (defun short-date (date)
   (cl-ppcre:regex-replace-all "-" (subseq date 0 10) "/"))
 
 (defun move->entry (move)
-  (let* ((account (agets move :account))
+  (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))))
+         (currency (agets move "currency" "shortName"))
+         (bill-currency (agets move "billCurrency" "shortName"))
+         (date (pta-ledger:parse-date (short-date (agets move "date"))))
          (payee (get-move-payee move))
          (description (get-move-description move))
-         (amount (parse-float (agets move :amount)))
-         (expense (equal "0" (agets move :type))))
+         (amount (agets move "amount"))
+         (bill-amount (agets move "billAmount")))
     (pta-ledger:make-entry
      :date date
      :description payee
@@ -189,33 +136,25 @@
                 (pta-ledger:make-posting
                  :account account2
                  :amount (pta-ledger:make-amount
-                          :quantity (* amount (if expense 1 -1))
-                          :commodity currency))
+                          :quantity (* bill-amount -1)
+                          :commodity bill-currency)
+                 :total-price (unless (equal currency bill-currency)
+                                (pta-ledger:make-amount
+                                 :quantity (* amount -1)
+                                 :commodity currency)))
                 (pta-ledger:make-posting
                  :account account1
                  :amount (pta-ledger:make-amount
-                          :quantity (* amount (if expense -1 1))
+                          :quantity amount
                           :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)))))
+  (let ((left-debt (agets account "leftDebt")))
+    (format nil "; balance ~A = ~,2F ~A"
+            (get-account-name account)
+            (if left-debt (* -1 left-debt) (agets account "balance"))
+            (get-account-currency account))))
 
-(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)
   (text-chunks (mapcar #'pta-ledger:render changes)))
@@ -225,38 +164,39 @@
 
 ;; Cron
 (defvar *last-entries* (make-hash-table) "Last per-chat entries")
-(defvar *cookie-jars* (make-hash-table) "Per-chat cookie jars")
+(defvar *tokens* (make-hash-table) "Per-chat access tokens")
 
 (defmacro with-chat-credentials ((chat-id) &body body)
-  `(let* ((*cookie-jar* (or (gethash ,chat-id *cookie-jars*)
-                            (cl-cookie:make-cookie-jar)))
+  `(let* ((*access-token* (gethash ,chat-id *tokens*))
           (*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))))))
+                                    (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*))))
+       (setf (gethash chat-id *tokens*) *access-token*))))
 
-(defun get-chat-last-entries (chat-id &optional (offset +day+))
+(defun get-chat-last-n-entries (chat-id &optional (count 10))
   (with-chat-credentials (chat-id)
-    (let* ((now (get-universal-time))
-           (pre (- now offset)))
-      (sort (mapcar #'move->entry (get-last-movements pre now))
+    (let ((accounts (^account))
+          (transactions (remove nil (agets (^transaction :size count) "list")
+                                :key (agetter "type"))))
+      (sort (loop for tr in transactions
+               collect (move->entry (append tr (list (cons "account" (get-transaction-account tr accounts))))))
             #'< :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)))))
+    (concatenate 'list (^account) (^loan))))
 
 (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+)))
+          (new (get-chat-last-n-entries chat-id 20))
           (ledger-package (find-package :chatikbot.plugins.ledger)))
       (when new
         (when old
-          (alexandria:when-let (changes (set-difference new old :test #'equalp))
+          (when-let (changes (set-difference new old :test #'equalp))
             (log:info changes)
             (if ledger-package
                 (let ((new-chat-entry (symbol-function
@@ -270,5 +210,5 @@
   (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+))))
+        (let ((last (get-chat-last-n-entries chat-id (if arg (parse-integer arg) 10))))
           (bot-send-message chat-id (format-entries last) :parse-mode "markdown")))))

plugins/rss.lisp

@@ -1,6 +1,6 @@
 (in-package :cl-user)
 (defpackage chatikbot.plugins.rss
-  (:use :cl :chatikbot.common))
+  (:use :cl :chatikbot.common :alexandria))
 (in-package :chatikbot.plugins.rss)
 
 (defstruct feed id url title next-fetch (period 300))

plugins/tumblr.lisp

@@ -1,6 +1,6 @@
 (in-package :cl-user)
 (defpackage chatikbot.plugins.tumblr
-  (:use :cl :chatikbot.common :chatikbot.eliza))
+  (:use :cl :chatikbot.common :chatikbot.eliza :alexandria))
 (in-package :chatikbot.plugins.tumblr)
 
 (defvar *tumblr-roll* nil "List of tumblr to select from")

plugins/vk.lisp

@@ -1,6 +1,6 @@
 (in-package :cl-user)
 (defpackage chatikbot.plugins.vk
-  (:use :cl :chatikbot.common))
+  (:use :cl :chatikbot.common :alexandria))
 (in-package :chatikbot.plugins.vk)
 
 (defparameter +vk-api-ver+ "5.53" "vk api version to use")

utils.lisp

@@ -20,9 +20,7 @@
            :replace-all
            :aget
            :agets
-           :mappend
-           :random-elt
-           :flatten
+           :agetter
            :preprocess-input
            :punctuation-p
            :read-from-string-no-punct
@@ -166,17 +164,9 @@ is replaced with replacement."
 (defun agets (alist &rest keys)
   (reduce #'(lambda (a k) (aget k a)) keys :initial-value alist))
 
-(defun mappend (fn &rest lists)
-  "Apply fn to each element of lists and append the results."
-  (apply #'append (apply #'mapcar fn lists)))
-
-(defun random-elt (choices)
-  "Choose an element from a list at random."
-  (elt choices (random (length choices))))
-
-(defun flatten (the-list)
-  "Append together elements (or lists) in the list."
-  (mappend #'(lambda (x) (if (listp x) (flatten x) (list x))) the-list))
+(defun agetter (&rest keys)
+  (lambda (alist)
+    (apply 'agets alist keys)))
 
 (defun preprocess-input (text)
   (when text
@@ -361,11 +351,14 @@ is replaced with replacement."
                                           (:hour 2) ":" (:min 2) ":" (:sec 2))))
 
 (defun parse-float (string)
-  (let ((*read-eval* nil))
-    (with-input-from-string (stream string)
-      (let ((in (read stream nil nil)))
-        (when (numberp in)
-          in)))))
+  (etypecase string
+    (number string)
+    (string
+     (let ((*read-eval* nil))
+       (with-input-from-string (stream string)
+         (let ((in (read stream nil nil)))
+           (when (numberp in)
+             in)))))))
 
 (defun smart-f (arg &optional digits)
   (with-output-to-string (s)