chatikbot/utils.lisp

(in-package :cl-user)
(defpackage chatikbot.utils
  (:use :cl)
  (:export :*admins*
           :*bot-name*
           :*hooks*
           :+day+
           :run-hooks
           :add-hook
           :remove-hook
           :keyify
           :dekeyify
           :*settings*
           :defsetting
           :*backoff-start*
           :*backoff-max*
           :loop-with-error-backoff
           :replace-all
           :aget
           :agets
           :mappend
           :random-elt
           :flatten
           :preprocess-input
           :punctuation-p
           :read-from-string-no-punct
           :print-with-spaces
           :spaced
           :http-request
           :xml-request
           :get-by-tag
           :select-text
           :trim-nil
           :text-with-cdata
           :child-text
           :clean-text
           :json-request
           :plist-hash
           :plist-json
           :format-ts
           :parse-cmd
           :parse-float
           :smart-f
           :format-size
           :format-interval
           :symbol-append
           :message-id
           :from-id
           :chat-id
           :text
           :cmd
           :args
           :callback
           :query-id
           :from
           :raw-data
           :message
           :data
           :section
           :code
           :error
           :raw-state
           :state
           :inline-message-id
           :source-message
           :source-message-id
           :source-chat-id
           :hook
           :headers
           :paths))
(in-package #:chatikbot.utils)

(defvar *admins* nil "Admins chat-ids")
(defvar *bot-name* nil "bot name to properly handle text input")
(defvar *hooks* (make-hash-table) "Hooks storage")
(defparameter +day+ (* 24 60 60) "Seconds in day")

(defun run-hooks (event &rest arguments)
  (let ((hooks (gethash event *hooks*)))
    (labels ((try-handle (func)
               (handler-case
                   (apply func arguments)
                 (error (e)
                   (log:error "Error processing event ~A: ~A" event e)
                   nil))))
      (unless (some #'try-handle hooks)
        (log:info "unhandled" event arguments)))))

(defun add-hook (event hook)
  (let ((existing (gethash event *hooks*)))
    (unless (member hook existing)
      (setf (gethash event *hooks*)
            (sort (cons hook existing) #'>
                  :key #'(lambda (h)
                           (etypecase h
                             (symbol (get h :prio 0))
                             (function 0))))))))

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

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

(defun dekeyify (keyword &optional preserve-dash)
  (let ((text (string-downcase (string keyword))))
    (if preserve-dash text (substitute #\_ #\- text))))

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

(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))))
           (usocket:timeout-error (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 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 preprocess-input (text)
  (when text
    (let* ((text (subseq text (if (equal (char text 0) #\/) 1 0)))
           (first-space (position #\Space text))
           (first-word (subseq text 0 first-space)))
      (if (equal first-word *bot-name*)
          (preprocess-input (subseq text (1+ first-space)))
          (replace-all text *bot-name* "ты")))))

(defun print-with-spaces (list)
  (format nil "~@(~{~a~^ ~}~)" list))

(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 spaced (list)
  (format nil "~{~A~^ ~}" list))

(defun http-default (url &optional parameters)
  (let* ((uri (quri:uri url))
         (userinfo (quri:uri-userinfo uri)))
    (when parameters
      (let ((query (quri:url-encode-params parameters :encoding :utf-8)))
        (setf (quri:uri-query uri)
              (if (and (quri:uri-query uri)
                       (string-not-equal (quri:uri-query uri) ""))
                  (concatenate 'string (quri:uri-query uri) "&" query)
                  query))))
    (when userinfo
      (setf (quri:uri-userinfo uri) nil))
    (unless (quri:uri-scheme uri)
      (setf (quri:uri-scheme uri) "http"))
    (values uri userinfo)))

(defun http-request (url &rest args &key method version parameters content headers basic-auth cookie-jar keep-alive use-connection-pool (max-redirects 5) timeout force-binary want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent)
  (declare (ignore method version content basic-auth cookie-jar keep-alive use-connection-pool max-redirects timeout force-binary want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path))
  (multiple-value-bind (uri userinfo)
      (http-default url parameters)
    (when userinfo
      (push (cons :authorization (concatenate 'string "Basic "
                                              (base64:string-to-base64-string userinfo)))
            headers))
    (when user-agent
      (push (cons :user-agent user-agent) headers)
      (remf args :user-agent))
    (remf args :parameters)
    (remf args :headers)
    (apply #'dex:request uri :headers headers args)))

;; XML processing
(defun xml-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 encoding)
  (declare (ignore method parameters headers content 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 :encoding)
  (multiple-value-bind (raw-body status headers uri)
      (apply #'http-request url :force-binary t args)
    (let ((encoding
           (or
            ;; 1. Provided encoding
            encoding
            ;; 2. Content-type header
            (ignore-errors
              (let ((ct (gethash "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 (1+ (position (char-code #\>) raw-body :start 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))))
       status headers uri))))

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

(defun select-text (node &optional selector)
  (ignore-errors
    (when selector (setf node (elt (clss:select selector node) 0)))
    (plump:traverse node #'(lambda (n) (setf (plump:text n) ""))
                    :test #'plump:comment-p)
    (plump:text (plump:strip node))))

(defun trim-nil (text)
  (when text
    (let ((text (string-trim " " text)))
      (unless (zerop (length text))
        text))))

(defun text-with-cdata (node)
  "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))))))
      (r node))))

(defun child-text (node tag)
  (alexandria:when-let (child (car (get-by-tag node tag)))
    (trim-nil (text-with-cdata child))))

(defun clean-text (text)
  (when text (trim-nil (plump:text (plump:parse text)))))

;; JSON processing
(defun json-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 (yason:parse body :object-as object-as) status headers uri)))

(defun plist-hash (plist &optional skip-nil (format-key #'identity) &rest hash-table-initargs)
  (cond
    ((and (consp plist) (keywordp (car plist)))
     (let ((table (apply #'make-hash-table hash-table-initargs)))
       (do ((tail plist (cddr tail)))
           ((not tail))
         (let ((key (funcall format-key (car tail)))
               (value (cadr tail)))
           (when (or value (not skip-nil))
             (setf (gethash key table)
                   (if (listp value)
                       (apply #'plist-hash value skip-nil format-key hash-table-initargs)
                       value)))))
       table))
    ((consp plist)
     (loop for item in plist collect (apply #'plist-hash item skip-nil format-key hash-table-initargs)))
    (:default plist)))

(defmethod yason:encode ((object (eql 'f)) &optional (stream *standard-output*))
  (write-string "false" stream)
  object)

(defun plist-json (plist)
  (with-output-to-string (stream)
    (yason:encode (plist-hash plist t #'dekeyify) stream)))

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

(defun parse-float (string)
  (let ((*read-eval* nil))
    (with-input-from-string (stream string)
      (read stream nil nil))))

(defun smart-f (arg &optional digits)
  (with-output-to-string (s)
    (prin1 (cond ((= (round arg) arg) (round arg))
                 (digits (float (/ (round (* arg (expt 10 digits)))
                                   (expt 10 digits))))
                 (t arg))
           s)))

(defun format-size (bytes)
  (cond
    ((< bytes 512) (smart-f bytes))
    ((< bytes (* 512 1024)) (format nil "~A KiB" (smart-f (/ bytes 1024) 1)))
    ((< bytes (* 512 1024 1024)) (format nil "~A MiB" (smart-f (/ bytes 1024 1024) 1)))
    ((< bytes (* 512 1024 1024 1024)) (format nil "~A GiB" (smart-f (/ bytes 1024 1024 1024) 1)))
    (:otherwise (format nil "~A TiB" (smart-f (/ bytes 1024 1024 1024 1024) 1)))))

(defun format-interval (seconds)
  (cond
    ((< seconds 60) (format nil "~A sec" seconds))
    ((< seconds (* 60 60)) (format nil "~A mins" (round seconds 60)))
    ((< seconds (* 60 60 24)) (format nil "~A hours" (round seconds (* 60 60))))
    ((< seconds (* 60 60 24 7)) (format nil "~A days" (round seconds (* 60 60 24))))
    ((< seconds (* 60 60 24 7 54)) (format nil "~A weeks" (round seconds (* 60 60 24 7))))
    (:otherwise (format nil "~A years" (smart-f (/ seconds (* 60 60 24 365.25)) 1)))))

(defun symbol-append (&rest symbols)
  (intern (apply #'concatenate 'string
                 (mapcar #'symbol-name symbols))))


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