chatikbot/utils.lisp

(in-package :cl-user)
(defpackage chatikbot.utils
  (:use :cl)
  (:export :*message*
           :*message-id*
           :*from-id*
           :*chat-id*
           :*text*
           :*cmd*
           :*args*
           :*query-id*
           :*from*
           :*raw-data*
           :*inline-message-id*
           :*source-message*
           :*source-chat-id*
           :*source-message-id*
           :*callback*
           :*data*
           :*section*
           :*code*
           :*error*
           :*raw-state*
           :*state*
           :*hook*
           :*headers*
           :*paths*

           :*admins*
           :*bot-name*
           :*hooks*
           :+hour+
           :+day+
           :*chat-default-timezone*
           :run-hooks
           :add-hook
           :remove-hook
           :is-admin
           :keyify
           :dekeyify
           :*settings*
           :defsetting
           :*backoff-start*
           :*backoff-max*
           :loop-with-error-backoff
           :replace-all
           :aget
           :agets
           :agetter
           :preprocess-input
           :punctuation-p
           :read-from-string-no-punct
           :print-with-spaces
           :spaced
           :text-chunks
           :http-request
           :xml-request
           :get-by-tag
           :select-text
	   :select-attr
           :trim-nil
           :text-with-cdata
           :unspacify
           :child-text
           :clean-text
           :json-request
           :plist-hash
           :plist-json
           :format-ts
           :parse-cmd
           :parse-float
           :smart-f
           :format-size
           :format-interval
           :symbol-append
           :get-chat-location
           :get-chat-timezone
           :same-time-in-chat
           :group-by
           :pmapcar
           :filled))
(in-package #:chatikbot.utils)

;; Special variables
(defvar *message*)
(defvar *message-id*)
(defvar *from-id*)
(defvar *chat-id*)
(defvar *text*)
(defvar *cmd*)
(defvar *args*)
(defvar *query-id*)
(defvar *from*)
(defvar *raw-data*)
(defvar *source-message*)
(defvar *inline-message-id*)
(defvar *source-chat-id*)
(defvar *source-message-id*)
(defvar *callback*)
(defvar *data*)
(defvar *section*)
(defvar *code*)
(defvar *error*)
(defvar *raw-state*)
(defvar *state*)
(defvar *hook*)
(defvar *headers*)
(defvar *paths*)

(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 +hour+ (* 60 60) "Seconds in an hour")
(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 is-admin (&optional (chat-id *chat-id*))
  (member chat-id *admins*))

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

(defun dekeyify (keyword &optional preserve-dash)
  (if (typep keyword 'string) keyword
      (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*)))
(defsetting *chat-default-timezone* -3 "Default timezone for chat users. GMT+3")

(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 agetter (&rest keys)
  (lambda (alist)
    (apply 'agets alist keys)))

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

(defparameter +lf-lf+ "

")
(defparameter +pre-pre+ "```
")
(defparameter +pre-post+ "```")

(defun text-chunks (elements &key (chunk-size 4096) (text-sep +lf-lf+) (pre-pre +pre-pre+) (pre-post +pre-post+))
  (loop for text in elements
     with page
     when (> (+ (length page) (length text) (length text-sep))
             chunk-size)
     collect (concatenate 'string pre-pre page pre-post) into pages and do (setf page nil)
     do (setf page (if page (concatenate 'string page text-sep text) text))
     finally (return (append pages (when page (list (concatenate 'string pre-pre page pre-post)))))))

(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 t) (use-connection-pool t) (max-redirects 5) read-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 read-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 t) read-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 read-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 select-attr (node attr &optional selector)
  (ignore-errors
   (when selector (setf node (elt (clss:select selector node) 0)))
   (plump:get-attribute node attr)))

(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)
               (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)))
  (defun unspacify (text)
    (string-trim " " (cl-ppcre:regex-replace-all ws-regex text " "))))

(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 read-timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent (object-as :alist) json-content)
  (declare (ignore method parameters basic-auth cookie-jar keep-alive use-connection-pool read-timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent))
  (when (and (consp content) json-content)
    (setf content (with-output-to-string (s) (yason:encode-alist content s)))
    (push (cons :content-type "application/json") headers))
  (remf args :object-as)
  (remf args :headers)
  (remf args :json-content)
  (remf args :content)
  (multiple-value-bind (body status headers uri)
      (apply #'http-request url :content content :headers headers 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)
  (etypecase string
    (number string)
    (string
     (let ((*read-eval* nil))
       (with-input-from-string (stream string)
         (let ((in (read stream nil nil)))
           (when (numberp in)
             in)))))))

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

(defun get-chat-location (&optional (chat-id *chat-id*))
  (let* ((forecast-package (find-package :chatikbot.plugins.forecast))
         (chat-locations-sym (when forecast-package
                               (intern "*CHAT-LOCATIONS*" forecast-package)))
         (chat-locations (when (and chat-locations-sym (boundp chat-locations-sym))
                           (symbol-value chat-locations-sym))))
    (when chat-locations (aget chat-id chat-locations))))

(defun get-chat-timezone (&optional (chat-id *chat-id*))
  (or (let ((chat-loc (get-chat-location chat-id)))
        (when chat-loc
          (round (- 7.5 (aget "latitude" chat-loc)) 15))) ;; Nautical time
      *chat-default-timezone*))

(defun same-time-in-chat (ut &optional (chat-id *chat-id*))
  (let ((chat-tz (get-chat-timezone chat-id))
        (current-tz (nth-value 8 (get-decoded-time))))
    (+ ut (* (- chat-tz current-tz) +hour+))))

(defun group-by (list getter)
  (let (grouped)
    (loop for item in list
       for key = (funcall getter item)
       for group = (agets grouped key)
       unless group do (let ((new-group (list key)))
                         (push new-group grouped)
                         (setf group new-group))
       do (push item (cdr group)))
    grouped))

(defun pmapcar (f list)
  (let ((result (mapcar (lambda (n) (eager-future2:pexec (funcall f n))) list)))
    (map-into result #'eager-future2:yield result)))

(defun filled (alist)
  (remove nil alist :key #'cdr))

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