[tescort] new site

chatikbot.lisp

@@ -119,6 +119,5 @@
          :name "process-updates")))
 
   ;; Notify admins
-  (dolist (admin *admins*)
-    (ignore-errors
-      (telegram-send-message admin (format nil "~A started at ~A" *bot-name* (format-ts (local-time:now)))))))
+  (ignore-errors
+    (telegram-send-message (car *admins*) (format nil "~A started at ~A" *bot-name* (format-ts (local-time:now))))))

plugins/tescort.lisp

@@ -15,7 +15,8 @@
              (:name . ("td:nth-of-type(2)"))
              (:city . ("td:nth-of-type(3)"))
              (:phone . ("td:nth-of-type(4)"))
-             (:comment . ("td:nth-of-type(5)"))))
+             (:comment . ("td:nth-of-type(5)"))
+             (:photos . ("td:nth-of-type(5) a" :attr :href :multiple t))))
      (:init . (("http://www.tescort.com/private/signin")
                ".signin-box form"
                (("username" . tescort-login)
@@ -36,17 +37,52 @@
                ".signin-box form"
                (("username" . annonce-login)
                 ("password" . annonce-pass))))
-     (:validate . "#header .sitemenu-logged"))))
+     (:validate . "#header .sitemenu-logged"))
+    (:escortnews
+     (:scrape (:request . ("https://my.escortnews.eu/ajax.php"
+                           :method :post
+                           :content (("s" . q)
+                                     ("action" . "viewBlacklistRecords")
+                                     ("page" . "1") ("s1" . "date") ("s2" . "0") ("m" . "0"))))
+      (:processor . en-request)
+      (:items . ".blacklist .record")
+      (:info (:date . ("ul li:nth-of-type(1)"))
+             (:name . ("ul li:nth-of-type(2)"))
+             (:phone . ("ul li:nth-of-type(3)"))
+             (:city . ("ul li:nth-of-type(4)"))
+             (:email . ("ul li:nth-of-type(5)"))
+             (:comment . (".text" :child 6))))
+     (:init . (("https://my.escortnews.eu/")
+               "#form_PopUp"
+               (("username" . escortnews-login)
+                ("password" . escortnews-pass))))
+     (:validate . ".countSearchBar"))
+    ))
+
+(defun en-request (url &rest args &key method parameters content headers basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent (object-as :alist))
+  (declare (ignore method parameters basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent))
+  (remf args :object-as)
+  (when content
+    (push (cons :content-type "application/json") headers))
+  (multiple-value-bind (body status headers uri)
+      (apply #'http-request url args)
+    (unless (stringp body)
+      (setf body (babel:octets-to-string body :encoding :utf-8)))
+    (values (plump:parse (agets (yason:parse body :object-as object-as) "html")) status headers uri)))
 
 (defvar *tescort-login*)
 (defvar *tescort-pass*)
 (defvar *annonce-login*)
 (defvar *annonce-pass*)
+(defvar *escortnews-login*)
+(defvar *escortnews-pass*)
 (defun get-common-context ()
   `((tescort-login . ,*tescort-login*)
     (tescort-pass . ,*tescort-pass*)
     (annonce-login . ,*annonce-login*)
-    (annonce-pass . ,*annonce-pass*)))
+    (annonce-pass . ,*annonce-pass*)
+    (escortnews-login . ,*escortnews-login*)
+    (escortnews-pass . ,*escortnews-pass*)))
 
 (defun search-blacklists (query)
   (let ((context (append (get-common-context)
@@ -79,7 +115,7 @@
                                     "Not found")
                         :parse-mode "markdown"))))
 
-(def-message-cmd-handler handler-cmd-blacklist (:blacklist :bl)
+(def-message-admin-cmd-handler handler-cmd-blacklist (:blacklist :bl)
   (cond
     ((null args) (bot-send-message chat-id "Enter query")
      (on-next-message chat-id

scraping.lisp

@@ -23,13 +23,13 @@
 (defun apply-context (template context)
   (sublis context template))
 
-(defun do-request (template &optional context)
+(defun do-request (template &optional context processor)
   (let ((args (apply-context template context)))
-    (apply 'xml-request `(,@args :cookie-jar ,*cookie-jar*))))
+    (apply (or processor 'xml-request) `(,@args :cookie-jar ,*cookie-jar*))))
 
-(defmacro with-request ((template &optional context) &body body)
+(defmacro with-request ((template &optional context processor) &Body body)
   `(multiple-value-bind (*current-dom* *current-status* *current-headers* *current-uri*)
-       (do-request ,template ,context)
+       (do-request ,template ,context ,processor)
      (declare (ignorable *current-dom* *current-status* *current-headers* *current-uri*))
      ,@body))
 
@@ -86,8 +86,10 @@
       (t (unspacify (text-with-cdata node))))))
 
 (defun extract-info (parent template &optional (uri *current-uri*))
-  (destructuring-bind (selector &key attr multiple) template
+  (destructuring-bind (selector &key child attr multiple) template
     (labels ((extract (n)
+               (when child
+                 (setf n (elt (plump:children n) child)))
                (extract-data n :attr attr :uri uri)))
       (let* ((nodes (clss:select selector parent))
              (data (map 'list #'extract nodes)))
@@ -104,6 +106,7 @@
 (defun scrape-list (info &optional context)
   (let* ((scrape (agets info :scrape))
          (request (agets scrape :request))
+         (processor (or (agets scrape :processor) #'xml-request))
          (init (agets info :init))
          (validate (agets info :validate)))
     (labels ((return-info ()
@@ -111,7 +114,7 @@
                                    (agets scrape :info))))
       (unless (have-cookies request)
         (do-form init context validate))
-      (with-request (request context)
+      (with-request (request context processor)
         (if (do-validate validate)
             (return-info)
             (progn

utils.lisp

@@ -296,14 +296,15 @@ is replaced with replacement."
   "Compiles all text nodes within the nesting-node into one string."
   (with-output-to-string (stream)
     (labels ((r (node)
-               (loop for child across (plump:children node)
-                  do (typecase child
-                       (plump:text-node (write-string (plump:text child) stream))
-                       (plump:cdata (write-string (plump:text child) stream))
-                       (plump:nesting-node (r child))))))
+               (typecase node
+                       (plump:text-node (write-string (plump:text node) stream))
+                       (plump:cdata (write-string (plump:text node) stream))
+                       (plump:nesting-node
+                        (loop for child across (plump:children node)
+                           do (r child))))))
       (r node))))
 
-(let ((ws-regex (cl-ppcre:create-scanner "[\\n 	]+" :multi-line-mode t)))
+(let ((ws-regex (cl-ppcre:create-scanner "[\\n  	]+" :multi-line-mode t)))
   (defun unspacify (text)
     (string-trim " " (cl-ppcre:regex-replace-all ws-regex text " "))))