chatikbot/plugins/finance.lisp

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

(defparameter +yahoo-url+ "https://query1.finance.yahoo.com/v7/finance/quote?lang=en-US&region=US&corsDomain=finance.yahoo.com&fields=regularMarketPrice" "Yahoo Finance API endpoint")
(defparameter +brent-url+ "http://www.cmegroup.com/CmeWS/mvc/Quotes/Future/424/G")

(defvar *default-symbols* '("USDRUB=X" "EURRUB=X" "GBPRUB=X"))

(defparameter +chart-ranges+ (list (cons "day" (* 24 60))
                                   (cons "week" (* 7 24 60))
                                   (cons "month" (* 30 24 60))
                                   (cons "quarter" (* 91 24 60))
                                   (cons "year" (* 365 24 60))))

(defun get-rates (&optional (symbols *default-symbols*))
  (let ((response (agets (json-request
                          +yahoo-url+
                          :parameters `(("symbols" . ,(format nil "~{~A~^,~}" symbols))))
                         "quoteResponse")))
    (when (aget "error" response)
      (error "Error in rates request"))
    (loop for rate in (agets response "result")
       collect (cons (aget "symbol" rate)
                     (aget "regularMarketPrice" rate)))))

(defun get-brent ()
  (handler-case
      (let ((last (read-from-string
                   (aget "last" (first (aget "quotes" (json-request  +brent-url+)))))))
        (when (numberp last)
          last))
    (error (e) (log:error e))))

(defparameter +btc-e-usd-url+ "https://btc-e.com/api/2/btc_usd/ticker" "BTC-e BTC/USD ticker url")
(defun get-btc-e ()
  (handler-case
      (aget "last" (aget "ticker" (json-request +btc-e-usd-url+)))
    (error (e) (log:error e))))

(defparameter +coindesk-btc-usd-url+ "https://api.coindesk.com/site/headerdata.json?currency=BTC" "coindesk.com api endpoint")
(defun get-coindesk-btc-usd ()
  (handler-case
      (agets (json-request +coindesk-btc-usd-url+)
             "bpi" "USD" "rate_float")
    (error (e) (log:error "~A" e))))


(defparameter +cex-currency-limits-url+ "https://cex.io/api/currency_limits" "cex.io currency limits endpoint")
(defparameter +cex-last-prices-url+ "https://cex.io/api/last_prices/" "cex.io last prices api endpoint")
(defun cex-pair-symbol (pair)
  (concatenate 'string (agets pair "symbol1") "/" (agets pair "symbol2")))
(defun get-cex-io-symbols ()
  (handler-case
      (mapcar 'cex-pair-symbol (agets (json-request +cex-currency-limits-url+) "data" "pairs"))
    (error (e) (log:error "~A" e))))

(defvar *cex-io-symbols* (get-cex-io-symbols) "List of all cex.io supported symbols. Will be loaded on init")

(defun get-cex-io-last-prices (&rest symbols)
  (handler-case
      (let* ((ends (remove-duplicates (mapcar (lambda (s) (subseq s (1+ (position #\/ s)))) symbols)
                                      :test 'equal))
             (data (agets (json-request (format nil "~a~{~a~^/~}" +cex-last-prices-url+ ends)) "data")))
        (loop for pair in data
              for symbol = (cex-pair-symbol pair)
              when (member symbol symbols :test 'equal)
                collect (cons symbol (parse-float (agets pair "lprice")))))
    (error (e) (log:error "~A" e))))

;; Formatting
(defvar *symbol-aliases*
  (alexandria:plist-hash-table
   '("BTC/USD" ("btc" "bitcoin" "биток")
     "BRENT" ("чёрная" "нефть" "brent" "oil")
     "USDRUB=X" ("зелёный" "бакс" "доллар" "usd")
     "EURRUB=X" ("гейро" "eur" "евро")
     "GBPRUB=X" ("британец" "gbp" "фунт" "стерлинг")
     "CZKRUB=X" ("чешка" "czk")
     "DKKRUB=X" ("дашка" "dkk")
     "ETHUSD=X" ("eth" "etherium" "эфир" "эфирум" "виталик"))
   :test #'equal))

(defun get-symbol-label (symbol)
  (let ((aliases (gethash symbol *symbol-aliases*)))
    (if aliases
        (car aliases)
        (let ((lower (string-downcase symbol)))
          (when (equal "=x" (subseq lower (- (length lower) 2)))
            (setf lower (subseq lower 0 (- (length lower) 2))))
          (if (= 6 (length lower))
              (format nil "~A/~A" (subseq lower 0 3) (subseq lower 3))
              lower)))))

;; Charts
(defun get-serie (series symbol)
  (mapcar #'(lambda (r) (list (car r) (caddr r)))
          (remove symbol series :key #'cadr :test-not #'equal)))

(defun range (seq &key (key 'identity))
  (loop
     for item in seq
     for value = (funcall key item)
     minimizing value into min
     maximizing value into max
     finally (return (values min max))))

(defvar *chart-points* 800 "Data points in chart")
(defun make-chart (series symbols)
  (let* ((r (multiple-value-list (range series :key #'car)))
         (fmt (if (<= (- (second r) (first r))
                      (* 60 60 36))
                  '((:hour 2) ":" (:min 2))
                  '((:day 2) "." (:month 2) " " (:hour 2) ":" (:min 2)))))
    (adw-charting:with-line-chart ((+ 90 *chart-points*)
                                   (floor (* 3 *chart-points*) 4))
      (loop for symbol in symbols
         do (adw-charting:add-series (get-symbol-label symbol)
                                     (get-serie series symbol)))
      (adw-charting:set-axis
       :x "Time" :draw-gridlines-p t
       :label-formatter #'(lambda (v)
                            (local-time:format-timestring
                             nil
                             (local-time:unix-to-timestamp v)
                             :format fmt)))
      (adw-charting:set-axis :y "RUB" :draw-gridlines-p t :label-formatter "~,2F")
      (adw-charting:save-file "chart.png"))))

;; Database
(def-db-init
  (db-execute "create table if not exists finance_ticker (ts, symbol, price, primary key (ts, symbol)) without rowid")
  (db-execute "create table if not exists finance_chat_symbols (chat_id, symbol, primary key (chat_id, symbol)) without rowid")
  (db-execute "create table if not exists finance_orders (chat_id, user_id, user_name, symbol, amount, open, open_at, close, close_at)")
  (db-execute "create index if not exists idx_finance_ticker_ts on finance_ticker(ts desc)"))

(defun migrate ()
  (db-execute "delete from finance_ticker")
  (db-execute "insert or ignore into finance_ticker (ts, symbol, price) select ts, ?, usd from finance where usd is not null" "USDRUB=X")
  (db-execute "insert or ignore into finance_ticker (ts, symbol, price) select ts, ?, eur from finance where eur is not null" "EURRUB=X")
  (db-execute "insert or ignore into finance_ticker (ts, symbol, price) select ts, ?, gbp from finance where gbp is not null" "GBPRUB=X")
  (db-execute "insert or ignore into finance_ticker (ts, symbol, price) select ts, ?, brent from finance where brent is not null" "BRENT")
  (db-execute "insert or ignore into finance_ticker (ts, symbol, price) select ts, ?, btc from finance where btc is not null" "BTCUSD"))

(defun db/add-finance (ts symbol price)
  (db-execute "insert into finance_ticker (ts, symbol, price) values (?, ?, ?)" ts symbol price))

(defun db/get-last-finance (&optional (symbols *default-symbols*))
  (loop for symbol in symbols
     for last = (db-select "select ts, symbol, price from finance_ticker where symbol = ? order by ts desc limit 1"
                           symbol)
     when last append last))

(defun db/get-finance-at (symbol ts &optional (window +DAY+))
  (db-single "select price from finance_ticker where symbol = ? and ts between ? and ? order by ts desc limit 1"
             symbol (- ts window) ts))

(defun db/get-chat-symbols (&optional chat-id)
  (mapcar #'car
          (if chat-id
              (db-select "select symbol from finance_chat_symbols where chat_id = ?" chat-id)
              (db-select "select distinct symbol from finance_chat_symbols union select symbol from finance_orders"))))

(defun db/set-chat-symbols (chat-id symbols)
  (db-transaction
    (db-execute "delete from finance_chat_symbols where chat_id = ?" chat-id)
    (dolist (symbol symbols)
      (db-execute "insert into finance_chat_symbols (chat_id, symbol) values (?, ?)"
                  chat-id symbol))))

(defun db/get-series (after-ts &optional (symbols *default-symbols*) (avg 60))
  (when symbols
    (let ((sql (format nil
                       "select ts/~a*~:*~a, symbol, avg(price) from finance_ticker where ts >= ? and symbol in (~{?~*~^, ~}) group by ts/~a, symbol order by ts"
                       avg symbols avg)))
      (apply #'db-select sql (local-time:timestamp-to-unix after-ts) symbols))))

(defun db/order-buy (chat-id user-id user-name symbol amount open open-at)
  (db-execute "insert into finance_orders (chat_id, user_id, user_name, symbol, amount, open, open_at) values (?, ?, ?, ?, ?, ?, ?)"
              chat-id user-id user-name symbol amount open open-at))

(defun db/order-sell (row-id amount close close-at)
  (db-execute "update finance_orders set amount = ?, close = ?, close_at = ? WHERE rowid = ?"
              amount close close-at row-id))

(defun db/order-del (row-id)
  (db-execute "delete from finance_orders WHERE rowid = ?" row-id))

(defun db/orders-get (chat-id &optional user-id symbol opened)
  (db-select "select rowid, user_id, user_name, symbol, amount, open, open_at, close, close_at from finance_orders where chat_id = ? and (user_id = ? or ?) and (symbol = ? or ?) and (close is null or ?) order by open_at, close_at"
             chat-id
             user-id (if (or (null user-id) (is-admin)) 1 0)
             symbol (if (null symbol) 1 0)
             (if opened 0 1)))

;; Cron
(defcron process-rates ()
  (let* ((ts (local-time:timestamp-to-unix (local-time:now)))
         (symbols (db/get-chat-symbols))
         (cex-symbols (intersection symbols *cex-io-symbols* :test 'equal))
         (rest-symbols (set-difference symbols cex-symbols))
         (rates (when rest-symbols (get-rates rest-symbols)))
         (cex-prices (when cex-symbols (apply 'get-cex-io-last-prices cex-symbols))))
    (loop for (symbol . price) in (append rates cex-prices)
       do (db/add-finance ts symbol price))))

;;; Hooks
(defun get-label-symbol (label)
  (or
   (loop for symbol being the hash-keys in *symbol-aliases* using (hash-value aliases)
      when (member label aliases :test #'string-equal)
        do (return symbol))
   (let ((upper (string-upcase label)))
     (if (member upper *cex-io-symbols* :test 'equal) upper
         (if (and (= 7 (length label))
                  (equal (elt label 3) #\/))
             (concatenate 'string (remove #\/ upper) "=X")
             upper)))))

(def-message-cmd-handler handler-rates (:rates)
  (let* ((symbols (or (mapcar #'get-label-symbol *args*)
                      (db/get-chat-symbols *chat-id*)
                      *default-symbols*))
         (last (db/get-last-finance symbols)))
    (bot-send-message (if last
                          (format nil "~{~A *~$*~^, ~} @ _~A_"
                                  (loop for (ts symbol price) in last
                                     append (list (get-symbol-label symbol) price))
                                  (format-ts (local-time:unix-to-timestamp (caar last))))
                          "Пока нет данных. Если тикер реальный, задай через /setrates <tickers>")
                      :parse-mode "markdown")))

(defun get-order-info (order)
  (destructuring-bind (row-id user-id user-name symbol amount-text open-text open-at close-text close-at)
      order
    (let* ((amount (parse-float amount-text))
           (open (parse-float open-text))
           (open-amount (* amount open))
           (close-at (or close-at (local-time:timestamp-to-unix (local-time:now))))
           (close (if close-text
                     (parse-float close-text)
                     (db/get-finance-at symbol close-at)))
           (close-amount (when close (* amount close)))
           (duration (- close-at open-at))
           (income (when close-amount (- close-amount open-amount)))
           (roi (when income (/ income open-amount)))
           (annual (when (and roi (not (zerop duration))) (* (/ roi duration) (* +day+ 365.25)))))
      `((:row-id . ,row-id)
        (:user-id . ,user-id)
        (:user-name . ,user-name)
        (:symbol . ,symbol)
        (:amount . ,amount)
        (:open . ,open)
        (:open-at . ,open-at)
        (:open-amount . ,open-amount)
        (:open-p . ,(null close-text))
        (:close . ,close)
        (:close-at . ,close-at)
        (:close-amount . ,close-amount)
        (:duration . ,duration)
        (:income . ,income)
        (:roi . ,roi)
        (:annual . ,annual)))))

(defun print-order-info (idx info)
  (format nil "~A) ~A: *~A* ~A _~A_ @ *~$* ~A _~A_ @ *~$*, заработал *~$*, ROI *~$*%"
          idx
          (agets info :user-name)
          (agets info :amount)
          (get-symbol-label (agets info :symbol))
          (format-ts (local-time:unix-to-timestamp (agets info :open-at)))
          (agets info :open)
          (if (agets info :open-p)
              (if (> (or (agets info :income) 0) 0) "📈" "📉")
              (if (> (or (agets info :income) 0) 0) "🏆" "🐟"))
          (if (agets info :open-p) "now"
              (format-ts (local-time:unix-to-timestamp (agets info :close-at))))
          (or (agets info :close) 0)
          (or (agets info :income) 0)
          (* 100 (or (agets info :roi) 0))))

(defun handle-hodl-show ()
  (let ((orders (db/orders-get *chat-id*)))
    (bot-send-message (if orders (format nil "~{~A~%~} 😇"
                                         (loop for order in orders for idx from 1
                                            collect (print-order-info idx (get-order-info order))))
                          "Нет ходлеров :(")
                      :parse-mode "markdown"
          :disable-notification 1)))

(defun handle-hodl-buy ()
  (handler-case
      (let ((symbol (get-label-symbol (nth 1 *args*)))
            (amount (* (parse-float (nth 2 *args*)) 1))
            (open (* (parse-float (nth 3 *args*)) 1))
            (open-at (if (nth 4 *args*) (local-time:parse-timestring (nth 4 *args*)) (local-time:now))))
        (db/order-buy *chat-id* *from-id* (agets *from* "username")
                      symbol (princ-to-string amount) (princ-to-string open)
                      (local-time:timestamp-to-unix open-at))
        (handle-hodl-show))
    (error (e)
      (log:error "~A" e)
      (bot-send-message "/hodl buy <SYM> <AMT> <PRICE> [YYYY-MM-DD]"))))

(defun handle-hodl-sell ()
  (handler-case
      (let* ((symbol (get-label-symbol (nth 1 *args*)))
             (amount (* (parse-float (nth 2 *args*)) 1))
             (close (* (parse-float (nth 3 *args*)) 1))
             (close-at (if (nth 4 *args*) (local-time:parse-timestring (nth 4 *args*)) (local-time:now)))
             (user-id (agets *from* "id"))
             (orders (db/orders-get *chat-id* user-id symbol t))
             (total-amount (apply #'+ (mapcar #'(lambda (o) (parse-float (nth 4 o))) orders))))
        (if (> amount total-amount)
            (bot-send-message (format nil "Нет у тебя столько ~A! (не хватает ~A)"
                                      (nth 1 *args*)
                                      (- amount total-amount)))
            (progn
              (loop for order in orders
                 for order-amount = (parse-float (nth 4 order))
                 while (> amount 0)
                 when (> order-amount amount)
                 do (db/order-buy *chat-id* (nth 1 order) (nth 2 order) (nth 3 order)
                                  (princ-to-string (- order-amount amount))
                                  (nth 5 order) (nth 6 order))
                 do (progn
                      (db/order-sell (nth 0 order)
                                          (princ-to-string (min amount order-amount))
                                          (princ-to-string close)
                                          (local-time:timestamp-to-unix close-at))
                      (decf amount order-amount)))
              (handle-hodl-show))))
    (error (e)
      (log:error "~A" e)
      (bot-send-message "/hodl sell <SYM> <AMT> <PRICE> [YYYY-MM-DD]"))))

(defun handle-hodl-del ()
  (handler-case
      (let* ((symbol (get-label-symbol (nth 1 *args*)))
             (amount (or (nth 2 *args*) (error "no amount")))
             (order (find amount (db/orders-get *chat-id* (agets *from* "id") symbol)
                          :key #'(lambda (r) (nth 4 r)) :test #'equal)))
        (if order
            (progn
              (db/order-del (car order))
              (handle-hodl-show))
            (bot-send-message (format nil "Не нашёл ~A ~A :(" amount (nth 1 *args*)))))
    (error (e)
      (log:error "~A" e)
      (bot-send-message "/hodl del <SYM> <AMT>"))))

(def-message-cmd-handler handle-hodl (:hodl :hodlers)
  (cond
    ((equal (car *args*) "buy") (handle-hodl-buy))
    ((equal (car *args*) "sell") (handle-hodl-sell))
    ((equal (car *args*) "del") (handle-hodl-del))
    (:otherwise (handle-hodl-show))))


(def-message-cmd-handler handler-charts (:charts)
  (telegram-send-chat-action *chat-id* "upload_photo")
  (let* ((args (mapcar 'string-downcase *args*))
         (all-symbols (db/get-chat-symbols *chat-id*))
         (symbols (or (intersection (mapcar #'get-label-symbol args) all-symbols :test 'equal) all-symbols))
         (day-range (some #'(lambda (a) (aget a +chart-ranges+)) args))
         (number (some #'(lambda (a) (parse-integer a :junk-allowed t)) args))
         (avg (* 60 (cond
                      (day-range (round day-range *chart-points*))
                      (number)
                      (:otherwise 1))))
         (after-ts (local-time:timestamp- (local-time:now)
                                          (* avg *chart-points*) :sec))
         (rates (db/get-last-finance symbols))
         (chart (make-chart (db/get-series after-ts symbols avg) symbols)))
    (telegram-send-photo *chat-id* chart
                         :caption
                         (format nil "~{~A ~$~^, ~} @ ~A"
                                 (loop for (ts symbol price) in rates
                                    append (list (get-symbol-label symbol) price))
                                 (format-ts (local-time:unix-to-timestamp (caar rates)))))))

(def-message-cmd-handler handler-set-rates (:setrates)
  (when *args*
      (db/set-chat-symbols *chat-id* (mapcar #'get-label-symbol *args*)))
  (bot-send-message (format nil "Пишем ~{_~a_~#[~; и ~:;, ~]~}"
                            (mapcar #'get-symbol-label (db/get-chat-symbols *chat-id*)))
                    :parse-mode "markdown"))