chatikbot/utils.lisp

(in-package #:chatikbot)

(defvar *bot-name* nil "bot name to properly handle text input")

(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 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 punctuation-p (char)
  (find char ".,;:'!?#-()\\\""))

(defun read-from-string-no-punct (input)
  "Read from an input string, ignoring punctuation."
  (let ((*package* (find-package 'chatikbot)))
    (read-from-string
     (concatenate 'string "(" (substitute-if #\space #'punctuation-p input) ")"))))

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

(defun switch-viewpoint (words)
  "Change I to you and vice versa, and so on."
  (sublis '((I . you) (you . I) (me . you) (am . are)
            (я ты) (ты я) (меня тебя) (тебя меня))
          words))

(defun use-eliza-rules (input rules)
  "Find some rule with which to transform the input."
  (rule-based-translator input rules
                         :action #'(lambda (bindings responses)
                                     (sublis (switch-viewpoint bindings)
                                             (random-elt responses)))))

(defun eliza (input rules)
  (let ((r (use-eliza-rules
            (read-from-string-no-punct input)
            rules)))
    (cond
      ((null r) nil)
      ((and (consp (car r)) (eq 'function (caar r)))
       (apply (cadar r) (cdr r)))
      ((keywordp (car r)) r)
      (t (print-with-spaces (flatten r))))))

(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)
    (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 (selector node)
  (ignore-errors
    (string-trim '(#\Newline #\Space #\Return) (plump:text (elt (clss:select selector node) 0)))))

;; 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 token-hmac (message &optional (hmac-length 12))
  (let ((hmac (crypto:make-hmac (crypto:ascii-string-to-byte-array *telegram-token*) :sha256)))
    (crypto:update-hmac hmac (crypto:ascii-string-to-byte-array message))
    (base64:usb8-array-to-base64-string
     (subseq (crypto:hmac-digest hmac) 0 hmac-length))))

(defun encode-callback-data (chat-id section data &optional (ttl 600) (hmac-length 12))
  (when (find #\: data)
    (error "Bad data."))
  (let* ((message (format nil "~A:~A:~A:~A"
                          (base64:integer-to-base64-string chat-id)
                          (base64:integer-to-base64-string
                           (+ ttl (local-time:timestamp-to-universal (local-time:now))))
                          section data))
         (encoded (format nil "~A$~A" message (token-hmac message hmac-length))))
    (when (> (length encoded) +telegram-max-callback-data-length+)
      (error "Max callback length exceeded"))
    encoded))

(defun decode-callback-data (chat-id raw-data &optional (hmac-length 12))
  (destructuring-bind (message hmac)
      (split-sequence:split-sequence #\$ raw-data :from-end t :count 2)
    (destructuring-bind (cid expire section data)
        (split-sequence:split-sequence #\: message :count 4)
      (unless (= chat-id (base64:base64-string-to-integer cid))
        (error "Wrong chat id."))
      (unless (>= (base64:base64-string-to-integer expire)
                  (local-time:timestamp-to-universal (local-time:now)))
        (error "Expired."))
      (unless (equal hmac (token-hmac message hmac-length))
        (error "Bad data."))
      (values data (intern (string-upcase section) "KEYWORD")))))

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

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

(defmacro def-callback-section-handler (name (&rest sections) &body body)
  `(def-callback-handler ,name (callback)
     (when chat-id
       (multiple-value-bind (data section) (decode-callback-data chat-id raw-data)
         (when (member section (list ,@sections))
           (log:info query-id from-id chat-id message-id section data)
           ,@body
           t)))))

(defun encode-oauth-state (section state)
  (format nil "~A$~A" section state))
(defun decode-oauth-state (raw-state)
  (destructuring-bind (section data)
      (split-sequence:split-sequence #\$ raw-state :count 2)
    (values data (intern (string-upcase section) "KEYWORD"))))

(defmacro def-oauth-handler (name (code error state) &body body)
  `(progn
     (defun ,name (,code ,error ,state)
       (declare (ignorable ,code ,error ,state))
       (handler-case (progn ,@body)
         (error (e)
           (log:error "~A" e)
           (hunchentoot:redirect "/error"))))
     (add-hook :oauth ',name)))

(defmacro def-oauth-section-handler (name (&rest sections) &body body)
  `(def-oauth-handler ,name (code error raw-state)
     (multiple-value-bind (state section) (decode-oauth-state raw-state)
       (when (member section (list ,@sections))
         ,@body
         t))))

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

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


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