chatikbot/utils.lisp

(in-package #:chatikbot)

(defvar *hooks* (make-hash-table) "Hooks storage")

(defun run-hooks (event &rest arguments)
  (let ((hooks (gethash event *hooks*)))
    (labels ((try-handle (func)
               (apply func arguments)))
      (unless (some #'try-handle hooks)
        (log:info "unhandled" event arguments)))))

(defun add-hook (event hook &optional append)
  (let ((existing (gethash event *hooks*)))
    (unless (member hook existing)
      (setf (gethash event *hooks*)
            (if append (append existing (list hook))
                (cons hook existing))))))

(defun remove-hook (event hook)
  (setf (gethash event *hooks*)
        (remove hook (gethash event *hooks*))))

(defun string-to-event (key)
  (intern (string-upcase (substitute #\- #\_ key)) :keyword))

;; Settings
(defvar *settings* nil "List of plugin's settings symbols")
(defmacro defsetting (var &optional val doc)
  `(progn (defvar ,var ,val ,doc)
          (push ',var *settings*)))

(defun load-settings ()
  (loop for (var val) in (db-select "select var, val from settings")
     do (setf (symbol-value (intern var))
              (handler-case (read-from-string val)
                (error (e) (log:error e))))))

(defun set-setting (symbol value)
  (handler-case
      (progn
        (db-execute "replace into settings (var, val) values (?, ?)"
                    (symbol-name symbol)
                    (write-to-string value))
        (setf (symbol-value symbol) value))
    (error (e) (log:error e))))

(defvar *backoff-start* 1 "Initial back-off")
(defvar *backoff-max* 64 "Maximum back-off delay")

(defun loop-with-error-backoff (func)
  (let ((backoff *backoff-start*))
    (loop
       do
         (handler-case
             (progn
               (funcall func)
               (setf backoff *backoff-start*))
           (error (e)
             (log:error e)
             (log:info "Backing off for" backoff)
             (sleep backoff)
             (setf backoff (min *backoff-max*
                                (* 2 backoff))))
           (bordeaux-threads:timeout (e)
             (log:error e)
             (log:info "Backing off for" backoff)
             (sleep backoff)
             (setf backoff (min *backoff-max*
                                (* 2 backoff))))))))

(defun replace-all (string part replacement &key (test #'char=))
  "Returns a new string in which all the occurences of the part
is replaced with replacement."
  (with-output-to-string (out)
    (loop with part-length = (length part)
       for old-pos = 0 then (+ pos part-length)
       for pos = (search part string
                         :start2 old-pos
                         :test test)
       do (write-string string out
                        :start old-pos
                        :end (or pos (length string)))
       when pos do (write-string replacement out)
       while pos)))

(defmacro aget (key alist)
  `(cdr (assoc ,key ,alist :test #'equal)))

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


;; Circular lists
(defun make-circular (items)
  "Make items list circular"
  (setf (cdr (last items)) items))

(defmacro push-circular (obj circ)
  "Move circ list and set head to obj"
  `(progn
     (pop ,circ)
     (setf (car ,circ) ,obj)))

(defmacro peek-circular (circ)
  "Get head of circular list"
  `(car ,circ))

(defmacro pop-circular (circ)
  "Get head of circular list"
  `(pop ,circ))

(defun flat-circular (circ)
  "Flattens circular list"
  (do ((cur (cdr circ) (cdr cur))
       (head circ)
       result)
      ((eq head cur)
       (nreverse (push (car cur) result)))
    (push (car cur) result)))

(defun preprocess-input (text)
  (when text
    (let ((first-word (subseq text 0 (position #\Space text))))
      (if (equal first-word "@chatikbot")
          (preprocess-input (subseq text 11))
          (replace-all text "@chatikbot" "ты")))))

(defun parse-cmd (text)
  (let* ((args (split-sequence:split-sequence #\Space (subseq text 1) :remove-empty-subseqs t))
         (cmd (subseq (car args) 0 (position #\@ (car args)))))
    (values (intern (string-upcase cmd) "KEYWORD") (rest args))))

(defun http-default (url)
  (let ((uri (puri:uri url)))
    (puri:render-uri
     (if (null (puri:uri-scheme uri))
         (puri:uri (format nil "http://~A" url))
         uri)
     nil)))

;; XML processing
(defun xml-request (url &key encoding parameters)
  (multiple-value-bind (raw-body status headers uri http-stream)
      (drakma:http-request (http-default url)
                           :parameters parameters
                           :external-format-out :utf-8
                           :force-binary t
                           :decode-content t)
    (declare (ignore status http-stream))
    (let ((encoding
           (or
            ;; 1. Provided encoding
            encoding
            ;; 2. Content-type header
            (ignore-errors
              (let ((ct (aget :content-type headers)))
                (subseq ct (1+ (position #\= ct)))))
            ;; 3. Parse first 1000 bytes
            (ignore-errors
              (let ((dom (plump:parse (flex:octets-to-string (subseq raw-body 0 1000)))))
                (or
                 ;; 3.1 Content-type from http-equiv
                 (ignore-errors
                   (let ((ct (loop for meta in (get-by-tag dom "meta")
                                for http-equiv = (plump:get-attribute meta "http-equiv")
                                for content = (plump:get-attribute meta "content")
                                when (equal http-equiv "Content-Type")
                                return content)))
                     (subseq ct (1+ (position #\= ct)))))
                 ;; 3.2 'content' xml node attribute
                 (ignore-errors (plump:get-attribute (plump:first-child dom) "encoding")))))
            ;; 4. Default 'utf-8'
            "utf-8")))
      (values
       (handler-bind ((flex:external-format-encoding-error
                       (lambda (c) (use-value #\? c))))
         (plump:parse
          (flex:octets-to-string raw-body :external-format (intern encoding 'keyword))))
       uri))))

(defun get-by-tag (node tag)
  (nreverse (org.shirakumo.plump.dom::get-elements-by-tag-name node tag)))

(defun select-text (selector node)
  (ignore-errors
    (string-trim '(#\Newline #\Space #\Return) (plump:text (elt (clss:select selector node) 0)))))

;; JSON processing
(defun json-request (url &key (method :get) parameters (object-as :alist))
  (multiple-value-bind (stream status headers uri http-stream)
      (drakma:http-request (http-default url) :method method :parameters parameters
                           :external-format-out :utf-8
                           :force-binary t :want-stream t :decode-content t)
    (declare (ignore status headers))
    (unwind-protect
         (progn
           (setf (flex:flexi-stream-external-format stream) :utf-8)
           (values (yason:parse stream :object-as object-as) uri))
      (ignore-errors (close http-stream)))))

(defun format-ts (ts)
  (local-time:format-timestring nil ts
                                :format '(:year "-" (:month 2) "-" (:day 2) " "
                                          (:hour 2) ":" (:min 2) ":" (:sec 2))))

(defun google-tts (text &key (lang "en"))
  (let ((path #P"google_tts.mp3"))
    (with-open-file (s path :direction :output
                       :element-type '(unsigned-byte 8)
                       :if-exists :supersede
                       :if-does-not-exist :create)
      (write-sequence
       (drakma:http-request
        "http://translate.google.com/translate_tts"
        :parameters `(("ie" . "UTF-8")
                      ("client" . "t")
                      ("tl" . ,lang)
                      ("q" . ,text))
        :user-agent "stagefright/1.2 (Linux;Android 5.0)"
        :additional-headers '((:referer . "http://translate.google.com/"))
        :external-format-out :utf-8
        :force-binary t)
       s)
      path)))

(defun say-it (lang words)
  (cons :voice
        (google-tts (print-with-spaces words) :lang lang)))

(defun yit-info ()
  (labels ((get-rows (url)
             (rest (get-by-tag (plump:get-element-by-id (xml-request url) "apartmentList") "tr")))
           (row-data (row)
             (mapcar (lambda (e) (string-trim '(#\Newline #\Space) (plump:text e)))
                     (get-by-tag row "td")))
           (format-data (data)
             (format nil "~{~A~^ ~}" (mapcar (lambda (n) (nth n data)) '(1 2 3 4 7 6))))
           (get-intresting (rows)
             (loop for row in rows
                for data = (row-data row)
                for rooms = (parse-integer (nth 2 data))
                for area = (parse-float:parse-float (replace-all (nth 3 data) "," "."))
                when (= rooms 3)
                when (< 65 area 75)
                collect data))
           (format-apts (url)
             (let ((apts (get-intresting (get-rows url))))
               (format nil "~A~%~{~A~^~%~}~%~A/~A" url (mapcar #'format-data apts)
                       (length (remove "забронировано" apts :test #'equal :key #'(lambda (r) (nth 7 r)) ))
                       (length apts)))))
    (format nil "~{~A~^~%~%~}"
            (mapcar #'format-apts
                    '("http://www.yitspb.ru/yit_spb/catalog/apartments/novoorlovskiy-korpus-1-1-1"
                      "http://www.yitspb.ru/yit_spb/catalog/apartments/novoorlovskiy-korpus-1-1-2")))))

(defmacro def-message-handler (name (message) &body body)
  `(progn
     (defun ,name (,message)
       (let ((message-id (aget "message_id" ,message))
             (from-id (aget "id" (aget "from" ,message)))
             (chat-id (aget "id" (aget "chat" ,message)))
             (text (aget "text" ,message)))
         (declare (ignorable message-id from-id chat-id text))
         (handler-case (progn ,@body)
           (error (e)
             (log:error "~A" e)
             (bot-send-message chat-id
                               (format nil "Ошибочка вышла~@[: ~A~]"
                                       (when (member chat-id *admins*) e)))))))
     (add-hook :update-message ',name)))

(defmacro def-message-cmd-handler (name (&rest commands) &body body)
  `(def-message-handler ,name (message)
     (when (and text (equal #\/ (char text 0)))
       (multiple-value-bind (cmd args) (parse-cmd text)
         (when (member cmd (list ,@commands))
           (log:info cmd message-id chat-id from-id args)
           ,@body
           t)))))

(defmacro def-message-admin-cmd-handler (name (&rest commands) &body body)
  `(def-message-handler ,name (message)
     (when (and (member chat-id *admins*)
                text (equal #\/ (char text 0)))
       (multiple-value-bind (cmd args) (parse-cmd text)
         (when (member cmd (list ,@commands))
           (log:info cmd message-id chat-id from-id args)
           ,@body
           t)))))

;; Schedule
(defmacro defcron (name (&rest schedule) &body body)
  (let ((schedule (or schedule '(:minute '* :hour '*))))
    `(progn
       (defun ,name ()
         (handler-case (progn ,@body)
           (error (e) (log:error e))))
       (add-hook :starting #'(lambda ()
                               (clon:schedule-function
                                ',name (clon:make-scheduler
                                        (clon:make-typed-cron-schedule
                                         ,@schedule)
                                        :allow-now-p t)
                                :name ',name :thread t)
                               (values))))))


;; Fix bug in local-time (following symlinks in /usr/share/zoneinfo/
;; leads to bad cutoff)
(in-package #:local-time)
(defun reread-timezone-repository (&key (timezone-repository *default-timezone-repository-path*))
  (check-type timezone-repository (or pathname string))
  (multiple-value-bind (valid? error)
      (ignore-errors
        (truename timezone-repository)
        t)
    (unless valid?
      (error "REREAD-TIMEZONE-REPOSITORY was called with invalid PROJECT-DIRECTORY (~A). The error is ~A."
             timezone-repository error)))
  (let* ((root-directory timezone-repository)
         (cutoff-position (length (princ-to-string root-directory))))
    (flet ((visitor (file)
             (handler-case
                 (let* ((full-name (subseq (princ-to-string file) cutoff-position))
                        (name (pathname-name file))
                        (timezone (%realize-timezone (make-timezone :path file :name name))))
                   (setf (gethash full-name *location-name->timezone*) timezone)
                   (map nil (lambda (subzone)
                              (push timezone (gethash (subzone-abbrev subzone)
                                                      *abbreviated-subzone-name->timezone-list*)))
                        (timezone-subzones timezone)))
               (invalid-timezone-file () nil))))
      (setf *location-name->timezone* (make-hash-table :test 'equal))
      (setf *abbreviated-subzone-name->timezone-list* (make-hash-table :test 'equal))
      (cl-fad:walk-directory root-directory #'visitor :directories nil :follow-symlinks nil
                             :test (lambda (file)
                                     (not (find "Etc" (pathname-directory file) :test #'string=))))
      (cl-fad:walk-directory (merge-pathnames "Etc/" root-directory) #'visitor :directories nil))))

(let ((zonepath "/usr/share/zoneinfo/"))
  (when (directory zonepath)
    (local-time:reread-timezone-repository :timezone-repository zonepath)))