chatikbot/plugins/shopper.lisp

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

(defvar *cookie-jar* (cl-cookie:make-cookie-jar) "Currently active cookies")

(defparameter +shops+
  `((:crc (:type :bike)
          (:form . (("http://www.chainreactioncycles.com/")
                    "#localepickerpage > form"
                    (("/atg/userprofiling/ProfileFormHandler.value.country" . "RU")
                     ("/atg/userprofiling/ProfileFormHandler.value.currency" . "EUR")
                     ("/atg/userprofiling/ProfileFormHandler.value.language" . "en"))))
          (:search (:request . ("http://www.chainreactioncycles.com/ru/en/s" :parameters (("q" . q))))
                   (:items . "div.products_details > ul")
                   (:info (:link . (".description > a" :href))
                          (:title . (".description"))
                          (:price . (".fromamt")))))
    (:b24 (:type . :bike)
          (:init . ("https://www.bike24.de/" :method :post
                   :content (("country" . "23")
                             ("lang" . "2")
                             ("action" . "locale_select"))))
         (:search (:request . ("https://www.bike24.de/1.php"
                               :parameters (("content" . "13") ("search" . q))))
                  (:items . ".box-product-list-item-default")
                  (:info (:link . ("a" :href))
                         (:title . (".title"))
                         (:price . (".box-price")))))
    (:bd (:type . :bike)
         (:init . ("https://www.bike-discount.de/index.php"
                   :parameters (("lang" . "en")
                                ("delivery_country" . "144")
                                ("currency" . "1"))))
         (:search (:request . ("https://www.bike-discount.de/en/search"
                               :parameters (("q" . q))))
                  (:items . ".element_artikel_gallery")
                  (:info (:link . ("a" :href))
                         (:title . (".productimage img" "alt"))
                         (:price . ("[itemprop='price']" "content")))))
    (:bc (:type . :bike)
         (:search (:request . ("https://www.bike-components.de/en/s/" :parameters (("keywords" . q))))
                  (:items . ".site-product-items > .item")
                  (:info (:link . ("a" :href))
                         (:title . ("h3"))
                         (:price . (".price")))))
    (:birota (:type :bike)
             (:search (:request . ("https://www.birota.ru/shop/search/index.php" :parameters (("q" . q))))
                      (:items . "[itemtype='http://schema.org/Product']")
                      (:info (:link . ("[itemprop='url']" :href))
                             (:title . ("[itemprop='name']" "content"))
                             (:price . (".price")))))))

(defun apply-context (template context)
  (sublis context template))

(defun do-request (template &optional context)
  (let ((args (apply-context template context)))
    (apply 'xml-request `(,@args :cookie-jar ,*cookie-jar*))))

(defun node-full-url (node attr uri)
  (quri:render-uri (quri:merge-uris (quri:uri (plump:attribute node attr)) uri)))

(defun do-form (form-info)
  (destructuring-bind (url form-selector context) form-info
    (multiple-value-bind (dom status headers uri)
        (do-request url)
      (declare (ignore status headers))
      (let ((form (clss:select form-selector dom)))
        (unless (zerop (length form))
          (let* ((form (elt form 0))
                 (action (node-full-url form "action" uri))
                 (method (or (keyify (plump:attribute form "method")) :get))
                 (content (append context
                                  (loop for input across (clss:select "input,select" form)
                                     for name = (plump:attribute input "name")
                                     for value = (plump:attribute input "value")
                                     when name
                                     unless (agets context name)
                                     collect (cons name value)))))
            (do-request `(,action :method ,method :content ,content))))))))

(defun extract-data (node template uri)
  (destructuring-bind (selector &optional post) template
    (let* ((nodes (clss:select selector node))
           (node (and (not (zerop (length nodes)))
                      (elt nodes 0))))
      (when node
        (cond
          ((eq :href post) (node-full-url node "href" uri))
          ((stringp post) (plump:attribute node post))
          (t (unspacify (text-with-cdata node))))))))

(defun parse-dom (uri dom items-selector info-templates &optional limit)
  (let ((nodes (clss:select items-selector dom)))
    (when limit
      (setf nodes (subseq nodes 0 (min limit (length nodes)))))
    (loop for node across nodes
       collect (loop for (key . template) in info-templates
                  collect (cons key (extract-data node template uri))))))

(defun have-cookies (request)
  (let ((uri (quri:uri (car request))))
    (cl-cookie:cookie-jar-host-cookies
     *cookie-jar* (quri:uri-host uri) (or (quri:uri-path uri) "/")
     :securep (string= (quri:uri-scheme uri) "https"))))

(defun search-shop (query params &optional limit)
  (let ((init (agets params :init))
        (form (agets params :form))
        (search (agets params :search)))
    (unless (have-cookies (agets search :request))
      (when init (do-request init))
      (when form (do-form form)))
    (multiple-value-bind (dom status headers uri)
        (do-request (agets search :request) `((q . ,query)))
      (declare (ignore status headers))
      (parse-dom uri dom (agets search :items) (agets search :info) limit))))

(defun search-shops (query shops &optional limit)
  (labels ((f (shop)
             (destructuring-bind (name . params) shop
               (ignore-errors
                 (cons name (search-shop query params limit))))))
    (pmapcar #'f shops)))

(defun merge-search-results (search-results)
  (let (merged)
    (dolist (shop search-results (nreverse merged))
      (dolist (res (cdr shop))
        (let* ((title (agets res :title))
               (pair (assoc title merged :test 'equal)))
          (unless pair
            (setf pair (car (push (list title) merged))))
          (push (cons (car shop) res) (cdr pair)))))))

(defun format-merged (merged)
  (with-output-to-string (s)
    (loop for (title . shops) in merged
       do (format s "~A - ~{*~A*: [~A](~A)~^, ~}~%" title
                  (loop for (name . result) in shops
                     append (list (dekeyify name)
                                  (agets result :price)
                                  (agets result :link)))))))

(defun handle-search (chat-id query)
  (let ((results (merge-search-results
                  (search-shops query +shops+ 3))))
    (bot-send-message chat-id (if results (format-merged results) "Ничего не нашлось")
                      :parse-mode "markdown" :disable-web-preview "true")))

(def-message-cmd-handler handler-cmd-wall (:bike)
  (cond
    ((null args) (bot-send-message chat-id "/bike <query>"))
    (:otherwise (handle-search chat-id (spaced args)))))